diff options
Diffstat (limited to 'fig-bless/src')
| -rw-r--r-- | fig-bless/src/Fig/Bless/Builtins.hs | 87 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless/Runtime.hs | 73 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless/Syntax.hs | 12 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless/TypeChecker.hs | 38 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless/Types.hs | 6 |
5 files changed, 153 insertions, 63 deletions
diff --git a/fig-bless/src/Fig/Bless/Builtins.hs b/fig-bless/src/Fig/Bless/Builtins.hs index 1246e57..8e199d7 100644 --- a/fig-bless/src/Fig/Bless/Builtins.hs +++ b/fig-bless/src/Fig/Bless/Builtins.hs @@ -9,48 +9,52 @@ import Fig.Prelude import Control.Monad.State.Strict (execStateT, StateT) import qualified Data.Map.Strict as Map +import qualified Data.Text as Text import qualified Fig.Bless.Syntax as Syn import Fig.Bless.Types import Fig.Bless.Runtime -- * Helper functions -stateful :: Running m t v => [BType] -> [BType] -> StateT (VM m t v) m a -> Builtin m t v +stateful :: Running m t => [BType] -> [BType] -> StateT (VM m t) m a -> Builtin m t stateful inp out f = (execStateT f, BProgType {..}) -push :: (Running m t v, MonadState (VM m' t v) m) => ValueF t v -> m () +push :: (Running m t, MonadState (VM m' t) m) => ValueF t -> m () push v = state \vm -> ((), vm { stack = v : vm.stack }) -pop :: (Running m t v, MonadState (VM m' t v) m) => m (ValueF t v) +pop :: (Running m t, MonadState (VM m' t) m) => m (ValueF t) pop = get >>= \case vm | x:xs <- vm.stack -> do put vm { stack = xs } pure x | otherwise -> throwM $ RuntimeErrorStackUnderflow ?term -int :: Running m t v => ValueF t v -> m Integer +effect :: (Running m t, MonadState (VM m' t) m) => EffectF t -> m () +effect e = state \vm -> ((), vm { effects = e : vm.effects }) + +int :: Running m t => ValueF t -> m Integer int (ValueInteger i) = pure i int v = throwM $ RuntimeErrorSortMismatch ?term ValueSortInteger (valueSort v) -double :: Running m t v => ValueF t v -> m Double +double :: Running m t => ValueF t -> m Double double (ValueDouble d) = pure d double v = throwM $ RuntimeErrorSortMismatch ?term ValueSortDouble (valueSort v) -string :: Running m t v => ValueF t v -> m Text +string :: Running m t => ValueF t -> m Text string (ValueString s) = pure s string v = throwM $ RuntimeErrorSortMismatch ?term ValueSortString (valueSort v) -program :: Running m t v => ValueF t v -> m (Syn.ProgramF t) +program :: Running m t => ValueF t -> m (Syn.ProgramF t) program (ValueProgram p) = pure p program v = throwM $ RuntimeErrorSortMismatch ?term ValueSortProgram (valueSort v) -array :: Running m t v => ValueF t v -> m [v] +array :: Running m t => ValueF t -> m [ValueF t] array (ValueArray a) = pure a array v = throwM $ RuntimeErrorSortMismatch ?term ValueSortProgram (valueSort v) -- * Stack operations -stackops :: RunningTop m t v => Builtins m t v -stackops t = let ?term = t in Map.fromList +stackOps :: RunningTop m t => Builtins m t +stackOps t = let ?term = t in Map.fromList [ ( "dup", stateful [BTypeVariable "a"] [BTypeVariable "a", BTypeVariable "a"] do x <- pop push x @@ -65,41 +69,86 @@ stackops t = let ?term = t in Map.fromList ] -- * Arithmetic builtins -add :: Running m t v => Builtin m t v +add :: Running m t => Builtin m t add = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do y <- int =<< pop x <- int =<< pop push . ValueInteger $ x + y -mul :: Running m t v => Builtin m t v +mul :: Running m t => Builtin m t mul = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do y <- int =<< pop x <- int =<< pop push . ValueInteger $ x * y -sub :: Running m t v => Builtin m t v +sub :: Running m t => Builtin m t sub = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do y <- int =<< pop x <- int =<< pop push . ValueInteger $ x - y -div :: Running m t v => Builtin m t v +div :: Running m t => Builtin m t div = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do y <- int =<< pop x <- int =<< pop push . ValueInteger $ quot x y -arithmetic :: RunningTop m t v => Builtins m t v -arithmetic t = let ?term = t in Map.fromList +arithmeticOps :: RunningTop m t => Builtins m t +arithmeticOps t = let ?term = t in Map.fromList [ ("+", add) , ("*", mul) , ("-", sub) , ("/", div) ] +-- * String builtins +stringOps :: RunningTop m t => Builtins m t +stringOps t = let ?term = t in Map.fromList + [ ( "s-append", stateful [BTypeString, BTypeString] [BTypeString] do + y <- string =<< pop + x <- string =<< pop + push . ValueString $ x <> y + ) + , ( "s-split", stateful [BTypeString, BTypeString] [BTypeArray BTypeString] do + sep <- string =<< pop + s <- string =<< pop + push . ValueArray $ ValueString <$> Text.splitOn sep s + ) + ] + +-- * Array builtins +arrayOps :: RunningTop m t => Builtins m t +arrayOps t = let ?term = t in Map.fromList + [ ( "a-append", stateful [BTypeArray (BTypeVariable "a"), BTypeArray (BTypeVariable "a")] [BTypeArray (BTypeVariable "a")] do + y <- array =<< pop + x <- array =<< pop + push . ValueArray $ x <> y + ) + ] + +-- * Side effects +sideeffectOps :: RunningTop m t => Builtins m t +sideeffectOps t = let ?term = t in Map.fromList + [ ( "print", stateful [BTypeVariable "a"] [] do + x <- pop + effect $ EffectPrint x + ) + , ( "soundboard", stateful [BTypeString] [] do + x <- pop + effect $ EffectSoundboard x + ) + , ( "toggle", stateful [BTypeString] [] do + x <- pop + effect $ EffectModelToggle x + ) + ] + -- * All builtins -builtins :: RunningTop m t v => Builtins m t v +builtins :: RunningTop m t => Builtins m t builtins t = Map.unions @[] - [ stackops t - , arithmetic t + [ stackOps t + , arithmeticOps t + , stringOps t + , arrayOps t + , sideeffectOps t ] diff --git a/fig-bless/src/Fig/Bless/Runtime.hs b/fig-bless/src/Fig/Bless/Runtime.hs index cbef849..c1170f3 100644 --- a/fig-bless/src/Fig/Bless/Runtime.hs +++ b/fig-bless/src/Fig/Bless/Runtime.hs @@ -1,7 +1,8 @@ {-# Language ImplicitParams #-} module Fig.Bless.Runtime - ( ValueF(..), Value + ( ValueF(..) + , EffectF(..) , ValueSort(..), valueSort , RuntimeError(..) , RunningTop, Running @@ -24,25 +25,37 @@ import qualified Data.Aeson as Aeson import Fig.Bless.Types import qualified Fig.Bless.Syntax as Syn -data ValueF t v +data ValueF t = ValueInteger Integer | ValueDouble Double | ValueString Text | ValueProgram (Syn.ProgramF t) - | ValueArray [v] + | ValueArray [ValueF t] deriving (Show, Eq, Ord, Generic) -instance (Aeson.ToJSON t, Aeson.ToJSON v) => Aeson.ToJSON (ValueF t v) -instance (Pretty t, Pretty v) => Pretty (ValueF t v) where +instance Aeson.ToJSON t => Aeson.ToJSON (ValueF t) +instance Pretty t => Pretty (ValueF t) where pretty (ValueInteger i) = tshow i pretty (ValueDouble d) = tshow d pretty (ValueString s) = tshow s pretty (ValueProgram p) = pretty p pretty (ValueArray vs) = mconcat - [ "[" - , Text.intercalate ", " $ pretty <$> vs - , "]" + [ "{" + , unwords $ pretty <$> vs + , "}" ] -type Value = ValueF (Fix Syn.TermF) (Fix (ValueF (Fix Syn.TermF))) + +data EffectF t + = EffectPrint (ValueF t) + | EffectPrintBackwards (ValueF t) + | EffectSoundboard (ValueF t) + | EffectModelToggle (ValueF t) + deriving (Show, Eq, Ord, Generic) +instance Aeson.ToJSON t => Aeson.ToJSON (EffectF t) +instance Pretty t => Pretty (EffectF t) where + pretty (EffectPrint x) = "(print " <> pretty x <> ")" + pretty (EffectPrintBackwards x) = "(print-backwards " <> pretty x <> ")" + pretty (EffectSoundboard x) = "(soundboard " <> pretty x <> ")" + pretty (EffectModelToggle x) = "(moddle-toggle " <> pretty x <> ")" data ValueSort = ValueSortInteger @@ -60,7 +73,7 @@ instance Pretty ValueSort where pretty ValueSortWord = "word" pretty ValueSortProgram = "program" pretty ValueSortArray = "list" -valueSort :: ValueF t v -> ValueSort +valueSort :: ValueF t -> ValueSort valueSort (ValueInteger _) = ValueSortInteger valueSort (ValueDouble _) = ValueSortDouble valueSort (ValueString _) = ValueSortString @@ -100,24 +113,26 @@ instance Pretty t => Pretty (RuntimeError t) where , "actual: ", pretty actual ] -type RunningTop m t v = (MonadThrow m, Typeable t, Show t) -type Running m t v = (RunningTop m t v, ?term :: Maybe t) -type BuiltinProgram m t v = VM m t v -> m (VM m t v) -type Builtin m t v = (BuiltinProgram m t v, BProgType) -type Builtins m t v = Maybe t -> Map Syn.Word (Builtin m t v) -data VM m t v = VM +type RunningTop m t = (MonadThrow m, Typeable t, Show t) +type Running m t = (RunningTop m t, ?term :: Maybe t) +type BuiltinProgram m t = VM m t -> m (VM m t) +type Builtin m t = (BuiltinProgram m t, BProgType) +type Builtins m t = Maybe t -> Map Syn.Word (Builtin m t) +data VM m t = VM { fuel :: Maybe Integer , bindings :: Syn.DictionaryF t - , builtins :: Builtins m t v - , stack :: [ValueF t v] + , builtins :: Builtins m t + , stack :: [ValueF t] + , effects :: [EffectF t] } -initialize :: Running m t v => Maybe Integer -> Syn.DictionaryF t -> Builtins m t v -> VM m t v +initialize :: Running m t => Maybe Integer -> Syn.DictionaryF t -> Builtins m t -> VM m t initialize fuel bindings builtins = VM{..} where stack = [] + effects = [] -checkFuel :: Running m t v => VM m t v -> m (VM m t v) +checkFuel :: Running m t => VM m t -> m (VM m t) checkFuel vm | Just f <- vm.fuel = if f <= 0 @@ -125,24 +140,28 @@ checkFuel vm else pure vm { fuel = Just $ f - 1 } checkFuel vm = pure vm -push :: Running m t v => ValueF t v -> VM m t v -> VM m t v +push :: Running m t => ValueF t -> VM m t -> VM m t push v vm = vm { stack = v : vm.stack } -runProgram :: Running m t v => Syn.Extractor m t -> Syn.ProgramF t -> VM m t v -> m (VM m t v) +runProgram :: Running m t => Syn.Extractor m t -> Syn.ProgramF t -> VM m t -> m (VM m t) runProgram f (Syn.Program p) vm = foldM (flip (run f)) vm p -runWord :: Running m t v => Syn.Extractor m t -> Syn.Word -> VM m t v -> m (VM m t v) +runWord :: Running m t => Syn.Extractor m t -> Syn.Word -> VM m t -> m (VM m t) runWord _ w vm | Just (b, _) <- Map.lookup w $ vm.builtins ?term = b vm runWord f w vm | Just p <- lookup w vm.bindings.defs = runProgram f p vm runWord _ w _ = throwM $ RuntimeErrorWordNotFound ?term w -run :: Running m t v => Syn.Extractor m t -> t -> VM m t v -> m (VM m t v) +literalValue :: Syn.Literal -> ValueF t +literalValue (Syn.LiteralInteger i) = ValueInteger i +literalValue (Syn.LiteralDouble i) = ValueDouble i +literalValue (Syn.LiteralString i) = ValueString i +literalValue (Syn.LiteralArray xs) = ValueArray $ literalValue <$> xs + +run :: Running m t => Syn.Extractor m t -> t -> VM m t -> m (VM m t) run f v vm = let ?term = Just v in f v >>= \case - Syn.TermLiteral (Syn.LiteralInteger i) -> push (ValueInteger i) <$> checkFuel vm - Syn.TermLiteral (Syn.LiteralDouble i) -> push (ValueDouble i) <$> checkFuel vm - Syn.TermLiteral (Syn.LiteralString i) -> push (ValueString i) <$> checkFuel vm + Syn.TermLiteral l -> push (literalValue l) <$> checkFuel vm Syn.TermQuote p -> push (ValueProgram p) <$> checkFuel vm Syn.TermWord w -> runWord f w =<< checkFuel vm diff --git a/fig-bless/src/Fig/Bless/Syntax.hs b/fig-bless/src/Fig/Bless/Syntax.hs index fc43917..f4dea0a 100644 --- a/fig-bless/src/Fig/Bless/Syntax.hs +++ b/fig-bless/src/Fig/Bless/Syntax.hs @@ -20,7 +20,6 @@ import Fig.Prelude import Data.Char (isSpace) import Data.Functor ((<&>)) -import Data.Text (unlines) import Data.String (IsString(..)) import qualified Text.Megaparsec as P @@ -41,12 +40,14 @@ data Literal = LiteralInteger Integer | LiteralDouble Double | LiteralString Text + | LiteralArray [Literal] deriving (Show, Eq, Ord, Generic) instance Aeson.ToJSON Literal instance Pretty Literal where pretty (LiteralInteger i) = tshow i pretty (LiteralDouble d) = tshow d pretty (LiteralString s) = tshow s + pretty (LiteralArray xs) = "{" <> unwords (pretty <$> xs) <> "}" newtype ProgramF t = Program [t] deriving (Show, Eq, Ord, Generic, Functor) @@ -98,8 +99,7 @@ literal = P.try ( (LiteralDouble <$> P.C.L.signed (pure ()) P.C.L.float) P.<?> "floating-point literal" ) P.<|> - ( - ( LiteralInteger <$> + ( (LiteralInteger <$> P.C.L.signed (pure ()) ( (P.C.string' "0x" *> P.C.L.hexadecimal) P.<|> (P.C.string' "0o" *> P.C.L.octal) P.<|> @@ -110,6 +110,9 @@ literal = ) P.<|> ( (LiteralString . pack <$> (P.C.char '"' *> P.manyTill P.C.L.charLiteral (P.C.char '"'))) P.<?> "string literal" + ) P.<|> + ( (LiteralArray <$> (P.C.char '{' *> P.many (ws *> literal <* ws) <* P.C.char '}')) + P.<?> "array literal" ) programF :: Parser t -> Parser (ProgramF t) @@ -157,8 +160,7 @@ data Spanning = Spanning { t :: TermF Spanning , start :: P.SourcePos , end :: P.SourcePos - } - deriving (Show, Eq, Ord, Generic) + } deriving (Show, Eq, Ord, Generic) instance Aeson.ToJSON Spanning where toJSON s = Aeson.object [ "term" Aeson..= Aeson.toJSON s.t diff --git a/fig-bless/src/Fig/Bless/TypeChecker.hs b/fig-bless/src/Fig/Bless/TypeChecker.hs index 0ee8eaf..272d98c 100644 --- a/fig-bless/src/Fig/Bless/TypeChecker.hs +++ b/fig-bless/src/Fig/Bless/TypeChecker.hs @@ -25,6 +25,7 @@ data TypeError t = TypeErrorWordNotFound (Maybe t) Word | TypeErrorMismatch (Maybe t) BType BType | TypeErrorArityMismatch (Maybe t) BProgType BProgType + | TypeErrorMixedArray (Maybe t) deriving (Show, Eq, Ord, Generic) instance (Show t, Typeable t) => Exception (TypeError t) instance Aeson.ToJSON t => Aeson.ToJSON (TypeError t) @@ -51,8 +52,12 @@ instance Pretty t => Pretty (TypeError t) where , "expected: ", pretty expected, "\n" , "actual: ", pretty actual ] + pretty (TypeErrorMixedArray t) = mconcat + [ typeErrorPrefix t + , "array literal has mixed types" + ] -type Typing m t = (MonadThrow m, Typeable t, Show t, ?term :: Maybe t) +type Typing m t = (MonadIO m, MonadThrow m, Typeable t, Show t, ?term :: Maybe t) completeSubstitution :: [(BType, BType)] -> Either ((BType, BType), [(BType, BType)]) (Map Text BType) completeSubstitution = go Map.empty @@ -66,6 +71,8 @@ completeSubstitution = go Map.empty unifyTypes :: forall m t. Typing m t => [(BType, BType)] -> m (Map Text BType) unifyTypes subst = case completeSubstitution subst of Right f -> pure f + Left ((BTypeArray t0, BTypeArray t1), xs) -- decompose arrays + -> unifyTypes ((t0, t1):xs) Left ((BTypeProgram p0, BTypeProgram p1), xs) -- decompose programs | length p0.inp == length p1.inp && length p0.out == length p1.out @@ -89,7 +96,7 @@ combineProgTypes f s = do ( \(l, d) t -> case l of x:xs | x == t -> pure (xs, d) - | otherwise -> throwM $ TypeErrorMismatch ?term x t + | otherwise -> throwM $ TypeErrorMismatch ?term t x [] -> pure (l, d <> [t]) ) (fout, []) @@ -99,6 +106,16 @@ combineProgTypes f s = do , out = sout <> leftover } +typeOfLiteral :: Typing m t => Literal -> m BType +typeOfLiteral LiteralInteger{} = pure BTypeInteger +typeOfLiteral LiteralDouble{} = pure BTypeDouble +typeOfLiteral LiteralString{} = pure BTypeString +typeOfLiteral (LiteralArray xs) = mapM typeOfLiteral xs >>= \case + [] -> pure $ BTypeArray (BTypeVariable "a") + ts@(t:_) + | length (Set.fromList ts) == 1 -> pure $ BTypeArray t + | otherwise -> throwM $ TypeErrorMixedArray ?term + typeOfProgram :: Typing m t => Env m t -> ProgramF t -> m BProgType typeOfProgram e (Program p) = case p of ft:ts -> do @@ -113,15 +130,12 @@ typeOf e wt = do TermWord w -> case lookup w e.defs of Nothing -> throwM $ TypeErrorWordNotFound ?term w Just p -> pure p - TermLiteral l -> pure BProgType - { inp = [] - , out = - [ case l of - LiteralInteger _ -> BTypeInteger - LiteralDouble _ -> BTypeDouble - LiteralString _ -> BTypeString - ] - } + TermLiteral l -> do + out <- typeOfLiteral l + pure BProgType + { inp = [] + , out = [out] + } TermQuote p -> do ty <- typeOfProgram e p pure BProgType @@ -129,7 +143,7 @@ typeOf e wt = do , out = [BTypeProgram ty] } -initializeEnv :: Extractor m t -> Builtins m t v -> Env m t +initializeEnv :: Extractor m t -> Builtins m t -> Env m t initializeEnv ext bs = Env { ext = ext , defs = (\(w, (_, p)) -> (w, p)) <$> Map.toList (bs Nothing) diff --git a/fig-bless/src/Fig/Bless/Types.hs b/fig-bless/src/Fig/Bless/Types.hs index ae8d9d4..c2e5d41 100644 --- a/fig-bless/src/Fig/Bless/Types.hs +++ b/fig-bless/src/Fig/Bless/Types.hs @@ -15,6 +15,7 @@ data BType | BTypeDouble | BTypeString | BTypeProgram BProgType + | BTypeArray BType deriving (Show, Eq, Ord, Generic) instance Aeson.ToJSON BType instance Pretty BType where @@ -23,6 +24,7 @@ instance Pretty BType where pretty BTypeDouble = "double" pretty BTypeString = "string" pretty (BTypeProgram p) = "(" <> pretty p <> ")" + pretty (BTypeArray p) = "Array<" <> pretty p <> ">" data BProgType = BProgType { inp :: [BType] @@ -35,6 +37,7 @@ instance Pretty BProgType where renameVars :: (Text -> Text) -> BType -> BType renameVars f (BTypeVariable v) = BTypeVariable $ f v +renameVars f (BTypeArray t) = BTypeArray $ renameVars f t renameVars f (BTypeProgram p) = BTypeProgram BProgType { inp = renameVars f <$> p.inp , out = renameVars f <$> p.out @@ -43,6 +46,7 @@ renameVars _ x = x substitute :: Text -> BType -> BType -> BType substitute n v (BTypeVariable n') | n == n' = v +substitute n v (BTypeArray t) = BTypeArray $ substitute n v t substitute n v (BTypeProgram p) = BTypeProgram BProgType { inp = substitute n v <$> p.inp , out = substitute n v <$> p.out @@ -53,6 +57,7 @@ applySubstitution :: Map Text BType -> BType -> BType applySubstitution s (BTypeVariable v) | Just x <- Map.lookup v s = x | otherwise = BTypeVariable v +applySubstitution s (BTypeArray t) = BTypeArray $ applySubstitution s t applySubstitution s (BTypeProgram p) = BTypeProgram BProgType { inp = applySubstitution s <$> p.inp , out = applySubstitution s <$> p.out @@ -61,5 +66,6 @@ applySubstitution _ x = x typeVariables :: BType -> Set Text typeVariables (BTypeVariable v) = Set.singleton v +typeVariables (BTypeArray t) = typeVariables t typeVariables (BTypeProgram p) = Set.unions $ (typeVariables <$> p.inp) <> (typeVariables <$> p.out) typeVariables _ = Set.empty |