diff options
| -rw-r--r-- | cabal.project | 1 | ||||
| -rw-r--r-- | fig-bless/fig-bless.cabal | 57 | ||||
| -rw-r--r-- | fig-bless/main/Main.hs | 144 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless.hs | 14 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless/Builtins.hs | 154 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless/Runtime.hs | 167 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless/Syntax.hs | 190 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless/TypeChecker.hs | 159 | ||||
| -rw-r--r-- | fig-bless/src/Fig/Bless/Types.hs | 84 |
9 files changed, 0 insertions, 970 deletions
diff --git a/cabal.project b/cabal.project index c15681c..850d58b 100644 --- a/cabal.project +++ b/cabal.project @@ -7,5 +7,4 @@ packages: fig-monitor-bullfrog/ fig-bridge-irc-discord/ fig-web/ - fig-bless/ optimization: 2 diff --git a/fig-bless/fig-bless.cabal b/fig-bless/fig-bless.cabal deleted file mode 100644 index a4fd35e..0000000 --- a/fig-bless/fig-bless.cabal +++ /dev/null @@ -1,57 +0,0 @@ -cabal-version: 3.4 -name: fig-bless -version: 0.1.0.0 - -common defaults - ghc-options: -Wall - default-language: GHC2021 - default-extensions: NoImplicitPrelude PackageImports LambdaCase MultiWayIf OverloadedStrings OverloadedLists OverloadedRecordDot DuplicateRecordFields RecordWildCards NoFieldSelectors BlockArguments ViewPatterns TypeFamilies DataKinds GADTs - -common deps - build-depends: - base - , aeson - , base64 - , binary - , bytestring - , containers - , data-default-class - , directory - , errors - , filepath - , http-types - , http-client - , http-client-tls - , lens - , megaparsec - , mtl - , req - , safe-exceptions - , text - , time - , tomland - , transformers - , unordered-containers - , vector - , fig-utils - , fig-bus - -library - import: defaults - import: deps - hs-source-dirs: src - exposed-modules: - Fig.Bless - Fig.Bless.Syntax - Fig.Bless.Types - Fig.Bless.TypeChecker - Fig.Bless.Runtime - Fig.Bless.Builtins - -executable fig-bless - import: defaults - import: deps - build-depends: fig-bless, optparse-applicative - hs-source-dirs: - main - main-is: Main.hs diff --git a/fig-bless/main/Main.hs b/fig-bless/main/Main.hs deleted file mode 100644 index f429638..0000000 --- a/fig-bless/main/Main.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# Language ApplicativeDo, ImplicitParams #-} - -module Main where - -import Fig.Prelude - -import Options.Applicative - -import Control.Exception.Safe (Handler(..), catches) - -import Data.Text.IO (putStr, putStrLn) -import qualified Data.Text.IO as T.IO -import qualified Data.ByteString.Lazy as B.L - -import qualified Data.Aeson as Aeson - -import Fig.Bless -import qualified Fig.Bless.Syntax as Syn - -data EvalOptions = EvalOptions - { src :: Text - , fuel :: Maybe Integer - } deriving Show - -parseEvalOptions :: Parser EvalOptions -parseEvalOptions = do - fuel <- optional $ option auto (long "fuel" <> short 'f' <> metavar "N" <> help "Maximum number of terms to run") - src <- unwords <$> some (argument str (metavar "TERM...")) - pure EvalOptions{..} - -newtype TypeOptions = TypeOptions - { src :: Text - } deriving Show - -parseTypeOptions :: Parser TypeOptions -parseTypeOptions = do - src <- unwords <$> some (argument str (metavar "TERM...")) - pure TypeOptions{..} - -data DictionaryOptions = DictionaryOptions - { path :: FilePath - , entrypoint :: Word - , fuel :: Maybe Integer - } deriving Show - -parseDictionaryOptions :: Parser DictionaryOptions -parseDictionaryOptions = do - fuel <- optional $ option auto (long "fuel" <> short 'f' <> metavar "N" <> help "Maximum number of terms to run") - entrypoint <- fmap (fromMaybe "main") . optional $ strOption (long "entrypoint" <> short 'e' <> metavar "WORD" <> help "Word to evaluate") - path <- argument str (metavar "PATH") - pure DictionaryOptions{..} - -data Command - = Eval EvalOptions - | Type TypeOptions - | Dict DictionaryOptions - deriving Show - -parseCommand :: Parser Command -parseCommand = subparser $ mconcat - [ command "eval" $ info (Eval <$> parseEvalOptions) (progDesc "Evaluate a Bless program") - , command "type" $ info (Type <$> parseTypeOptions) (progDesc "Check the type of a Bless program") - , command "dictionary" $ info (Dict <$> parseDictionaryOptions) (progDesc "Load and run a Bless dictionary") - ] - -data Options = Options - { cmd :: Command - , json :: Bool - } deriving Show - -parseOptions :: Parser Options -parseOptions = do - json <- flag False True (long "json" <> short 'j' <> help "Write output as JSON") - cmd <- parseCommand - pure Options{..} - -writeError :: (MonadIO m, Pretty e, Aeson.ToJSON e) => Options -> e -> m () -writeError o e - | o.json = liftIO . putStrLn . decodeUtf8 . B.L.toStrict . Aeson.encode $ Aeson.object - [ "status" Aeson..= ("error" :: Text) - , "data" Aeson..= Aeson.object - [ "structure" Aeson..= e - , "message" Aeson..= pretty e - ] - ] - | otherwise = liftIO . hPutStrLn stderr $ pretty e - -writeEval :: (MonadIO m, Pretty t, Aeson.ToJSON t) => Options -> [ValueF t] -> [EffectF t] -> m () -writeEval o st ef - | o.json = liftIO . putStrLn . decodeUtf8 . B.L.toStrict . Aeson.encode $ Aeson.object - [ "status" Aeson..= ("success" :: Text) - , "data" Aeson..= Aeson.object - [ "stack" Aeson..= st - , "effects" Aeson..= reverse ef - ] - ] - | otherwise = do - liftIO . putStr $ "Stack:\n" <> pretty st - liftIO . putStr $ "Effects:\n" <> pretty (reverse ef) - -writeType :: (MonadIO m, Pretty e, Aeson.ToJSON e) => Options -> e -> m () -writeType o t - | o.json = liftIO . putStrLn . decodeUtf8 . B.L.toStrict . Aeson.encode $ Aeson.object - [ "status" Aeson..= ("error" :: Text) - , "data" Aeson..= t - ] - | otherwise = liftIO . hPutStrLn stderr $ pretty t - -main :: IO () -main = do - opts <- execParser $ info (parseOptions <**> helper) - ( fullDesc - <> header "fig-bless - tools for the Bless language" - ) - catches - ( case opts.cmd of - Eval eo -> do - prog <- parse "<input>" (programF spanning <* eof) eo.src - let ?term = Nothing - let ext = pure . unSpanning - _ty <- typeOfProgram (initializeEnv ext builtins) prog - let vm = initialize eo.fuel (Dictionary mempty) builtins - vm' <- runProgram ext prog vm - writeEval opts vm'.stack vm'.effects - Type to -> do - prog <- parse "<input>" (programF spanning <* eof) to.src - let ?term = Nothing - let ext = pure . unSpanning - ty <- typeOfProgram (initializeEnv ext builtins) prog - writeType opts ty - Dict o -> do - src <- T.IO.readFile o.path - dict <- parse "<input>" (dictionaryF spanning <* eof) src - let ?term = Nothing - let ext = pure . unSpanning - _env <- checkDictionary (initializeEnv ext builtins) dict - let vm = initialize o.fuel dict builtins - vm' <- runWord ext o.entrypoint vm - writeEval opts vm'.stack vm'.effects - ) - [ Handler \(e :: Syn.ParseError) -> writeError opts e - , Handler \(e :: RuntimeError Spanning) -> writeError opts e - , Handler \(e :: TypeError Spanning) -> writeError opts e - ] diff --git a/fig-bless/src/Fig/Bless.hs b/fig-bless/src/Fig/Bless.hs deleted file mode 100644 index 1005a49..0000000 --- a/fig-bless/src/Fig/Bless.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Fig.Bless - ( module Fig.Bless.Syntax - , module Fig.Bless.Runtime - , module Fig.Bless.Builtins - , module Fig.Bless.Types - , module Fig.Bless.TypeChecker - ) -where - -import Fig.Bless.Syntax -import Fig.Bless.Runtime -import Fig.Bless.Builtins -import Fig.Bless.Types -import Fig.Bless.TypeChecker diff --git a/fig-bless/src/Fig/Bless/Builtins.hs b/fig-bless/src/Fig/Bless/Builtins.hs deleted file mode 100644 index 8e199d7..0000000 --- a/fig-bless/src/Fig/Bless/Builtins.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# Language ImplicitParams #-} - -module Fig.Bless.Builtins - ( builtins - ) where - -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 => [BType] -> [BType] -> StateT (VM m t) m a -> Builtin m t -stateful inp out f = (execStateT f, BProgType {..}) - -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, 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 - -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 => ValueF t -> m Double -double (ValueDouble d) = pure d -double v = throwM $ RuntimeErrorSortMismatch ?term ValueSortDouble (valueSort v) - -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 => ValueF t -> m (Syn.ProgramF t) -program (ValueProgram p) = pure p -program v = throwM $ RuntimeErrorSortMismatch ?term ValueSortProgram (valueSort 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 => Builtins m t -stackOps t = let ?term = t in Map.fromList - [ ( "dup", stateful [BTypeVariable "a"] [BTypeVariable "a", BTypeVariable "a"] do - x <- pop - push x - push x - ) - , ( "swap", stateful [BTypeVariable "a", BTypeVariable "b"] [BTypeVariable "b", BTypeVariable "a"] do - x <- pop - y <- pop - push x - push y - ) - ] - --- * Arithmetic builtins -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 => Builtin m t -mul = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do - y <- int =<< pop - x <- int =<< pop - push . ValueInteger $ x * y - -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 => Builtin m t -div = stateful [BTypeInteger, BTypeInteger] [BTypeInteger] do - y <- int =<< pop - x <- int =<< pop - push . ValueInteger $ quot x y - -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 => Builtins m t -builtins t = Map.unions @[] - [ 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 deleted file mode 100644 index 4de75e0..0000000 --- a/fig-bless/src/Fig/Bless/Runtime.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# Language ImplicitParams #-} - -module Fig.Bless.Runtime - ( ValueF(..) - , EffectF(..) - , ValueSort(..), valueSort - , RuntimeError(..) - , RunningTop, Running - , BuiltinProgram, Builtin, Builtins - , VM(..) - , initialize - , runProgram, runWord, run - ) where - -import Fig.Prelude - -import Control.Exception.Safe (Typeable) - -import qualified Data.Text as Text -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map - -import qualified Data.Aeson as Aeson - -import Fig.Bless.Types -import qualified Fig.Bless.Syntax as Syn - -data ValueF t - = ValueInteger Integer - | ValueDouble Double - | ValueString Text - | ValueProgram (Syn.ProgramF t) - | ValueArray [ValueF t] - deriving (Show, Eq, Ord, Generic) -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 - [ "{" - , unwords $ pretty <$> vs - , "}" - ] - -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 - | ValueSortDouble - | ValueSortString - | ValueSortWord - | ValueSortProgram - | ValueSortArray - deriving (Show, Eq, Ord, Generic) -instance Aeson.ToJSON ValueSort -instance Pretty ValueSort where - pretty ValueSortInteger = "integer" - pretty ValueSortDouble = "double" - pretty ValueSortString = "string" - pretty ValueSortWord = "word" - pretty ValueSortProgram = "program" - pretty ValueSortArray = "list" -valueSort :: ValueF t -> ValueSort -valueSort (ValueInteger _) = ValueSortInteger -valueSort (ValueDouble _) = ValueSortDouble -valueSort (ValueString _) = ValueSortString -valueSort (ValueProgram _) = ValueSortProgram -valueSort (ValueArray _) = ValueSortArray - -data RuntimeError t - = RuntimeErrorWordNotFound (Maybe t) Syn.Word - | RuntimeErrorOutOfFuel (Maybe t) - | RuntimeErrorStackUnderflow (Maybe t) - | RuntimeErrorSortMismatch (Maybe t) ValueSort ValueSort - deriving (Show, Eq, Ord, Generic) -instance (Show t, Typeable t) => Exception (RuntimeError t) -instance Aeson.ToJSON t => Aeson.ToJSON (RuntimeError t) -runtimeErrorPrefix :: Pretty t => Maybe t -> Text -runtimeErrorPrefix Nothing = "" -runtimeErrorPrefix (Just t) = mconcat - [ "while evaluating term: ", pretty t, "\n" - ] -instance Pretty t => Pretty (RuntimeError t) where - pretty (RuntimeErrorWordNotFound t w) = mconcat - [ runtimeErrorPrefix t - , "word definition not found for: ", pretty w - ] - pretty (RuntimeErrorOutOfFuel t) = mconcat - [ runtimeErrorPrefix t - , "out of fuel" - ] - pretty (RuntimeErrorStackUnderflow t) = mconcat - [ runtimeErrorPrefix t - , "stack underflow" - ] - pretty (RuntimeErrorSortMismatch t expected actual) = mconcat - [ runtimeErrorPrefix t - , "sort mismatch at runtime (this probably shouldn't happen, please report it as a bug):\n" - , "expected: ", pretty expected, "\n" - , "actual: ", pretty actual - ] - -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 - , stack :: [ValueF t] - , effects :: [EffectF t] - } - -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 => VM m t -> m (VM m t) -checkFuel vm - | Just f <- vm.fuel - = if f <= 0 - then throwM $ RuntimeErrorOutOfFuel ?term - else pure vm { fuel = Just $ f - 1 } -checkFuel vm = pure vm - -push :: Running m t => ValueF t -> VM m t -> VM m t -push v vm = vm - { stack = v : vm.stack - } - -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 => 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 - -literalValue :: Syn.LiteralF t -> 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 -literalValue (Syn.LiteralQuote p) = ValueProgram p - -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 l -> push (literalValue l) <$> 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 deleted file mode 100644 index 9cd8aec..0000000 --- a/fig-bless/src/Fig/Bless/Syntax.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# Language ApplicativeDo #-} - -module Fig.Bless.Syntax - ( Word(..) - , LiteralF(..) - , ProgramF(..) - , Program - , TermF(..) - , Term - , DictionaryF(..) - , Dictionary - , Extractor - , word, literalF, termF, term, programF, program, dictionaryF, dictionary, P.eof - , Spanning(..), unSpanning, spanning - , ParseError(..) - , parse - ) where - -import Fig.Prelude - -import Data.Char (isSpace) -import Data.Functor ((<&>)) -import Data.String (IsString(..)) - -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P.C -import qualified Text.Megaparsec.Char.Lexer as P.C.L - -import qualified Data.Aeson as Aeson - -newtype Word = Word Text - deriving (Show, Eq, Ord, Generic) -instance Aeson.ToJSON Word -instance IsString Word where - fromString = Word . fromString -instance Pretty Word where - pretty (Word t) = t - -data LiteralF t - = LiteralInteger Integer - | LiteralDouble Double - | LiteralString Text - | LiteralArray [LiteralF t] - | LiteralQuote (ProgramF t) - deriving (Show, Eq, Ord, Generic, Functor) -instance Aeson.ToJSON t => Aeson.ToJSON (LiteralF t) -instance Pretty t => Pretty (LiteralF t) where - pretty (LiteralInteger i) = tshow i - pretty (LiteralDouble d) = tshow d - pretty (LiteralString s) = tshow s - pretty (LiteralArray xs) = "{" <> unwords (pretty <$> xs) <> "}" - pretty (LiteralQuote p) = pretty p - -newtype ProgramF t = Program [t] - deriving (Show, Eq, Ord, Generic, Functor) -instance Aeson.ToJSON t => Aeson.ToJSON (ProgramF t) -instance Pretty t => Pretty (ProgramF t) where - pretty (Program ts) = unwords $ pretty <$> ts -type Program = ProgramF (Fix TermF) - -data TermF t - = TermWord Word - | TermLiteral (LiteralF t) - deriving (Show, Eq, Ord, Generic, Functor) -instance Aeson.ToJSON t => Aeson.ToJSON (TermF t) -instance Pretty t => Pretty (TermF t) where - pretty (TermWord w) = pretty w - pretty (TermLiteral l) = pretty l -type Term = TermF (Fix TermF) - -newtype DictionaryF t = Dictionary - { defs :: [(Word, ProgramF t)] - } deriving (Show, Eq, Ord) -instance Pretty t => Pretty (DictionaryF t) where - pretty d = unlines $ d.defs <&> \(w, p) -> mconcat - [ pretty w - , " = " - , pretty p - ] -type Dictionary = DictionaryF (Fix TermF) - -type Extractor m t = t -> m (TermF t) - -type Parser = P.Parsec Void Text - -ws :: Parser () -ws = P.C.L.space - P.C.space1 - (P.C.L.skipLineComment "//") - (P.C.L.skipBlockComment "/*" "*/") - -wordChar :: Char -> Bool -wordChar c = not $ elem @[] c ['[', ']', '{', '}', '=', ';'] || isSpace c -word :: Parser Word -word = Word . pack <$> P.some (P.satisfy wordChar) - -literalF :: Parser t -> Parser (LiteralF t) -literalF pt = - P.try ( (LiteralDouble <$> P.C.L.signed (pure ()) P.C.L.float) - P.<?> "floating-point literal" - ) P.<|> - ( (LiteralInteger <$> - P.C.L.signed (pure ()) - ( (P.C.string' "0x" *> P.C.L.hexadecimal) P.<|> - (P.C.string' "0o" *> P.C.L.octal) P.<|> - (P.C.string' "0b" *> P.C.L.binary) P.<|> - P.C.L.decimal - ) - ) P.<?> "integer 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 *> literalF pt <* ws) <* P.C.char '}')) - P.<?> "array literal" - ) P.<|> - ( (LiteralQuote <$> (P.C.char '[' *> programF pt <* P.C.char ']')) - P.<?> "quotation" - ) - -programF :: Parser t -> Parser (ProgramF t) -programF pt = Program <$> P.many (ws *> pt <* ws) - -program :: Parser Program -program = programF $ Fix <$> term - -termF :: Parser t -> Parser (TermF t) -termF pt = - ( P.try (TermLiteral <$> literalF pt) - P.<|> (TermWord <$> word) - ) P.<?> "term" - -term :: Parser Term -term = termF $ Fix <$> term - -dictionaryF :: Parser t -> Parser (DictionaryF t) -dictionaryF pt = Dictionary <$> P.many - ( (,) - <$> (ws *> word <* ws <* P.C.char '=') - <*> (ws *> programF pt <* ws <* P.C.char ';') - ) - -dictionary :: Parser Dictionary -dictionary = dictionaryF $ Fix <$> term - -newtype ParseError = ParseError (P.ParseErrorBundle Text Void) - deriving (Show, Generic) -instance Exception ParseError -instance Aeson.ToJSON ParseError where - toJSON (ParseError b) = Aeson.object - [ "errors" Aeson..= Aeson.toJSON (bimap P.parseErrorPretty P.sourcePosPretty <$> posed) - ] - where - (posed, _) = P.attachSourcePos P.errorOffset (P.bundleErrors b) (P.bundlePosState b) -instance Pretty ParseError where - pretty (ParseError b) = mconcat - [ "failed to read program:\n" - , pack $ P.errorBundlePretty b - ] - -data Spanning = Spanning - { t :: TermF Spanning - , start :: P.SourcePos - , end :: P.SourcePos - } deriving (Show, Eq, Ord, Generic) -instance Aeson.ToJSON Spanning where - toJSON s = Aeson.object - [ "term" Aeson..= Aeson.toJSON s.t - , "start" Aeson..= pack (P.sourcePosPretty s.start) - , "end" Aeson..= pack (P.sourcePosPretty s.end) - ] -instance Pretty Spanning where - pretty s = mconcat - [ pretty s.t, "\n" - , pack $ P.sourcePosPretty s.start, ":" - ] -unSpanning :: Spanning -> TermF Spanning -unSpanning s = s.t - -spanning :: Parser Spanning -spanning = do - start <- P.getSourcePos - t <- termF spanning - end <- P.getSourcePos - pure Spanning{..} - -parse :: MonadThrow m => Text -> Parser a -> Text -> m a -parse nm p inp = case P.runParser p (unpack nm) inp of - Left err -> throwM $ ParseError err - Right x -> pure x diff --git a/fig-bless/src/Fig/Bless/TypeChecker.hs b/fig-bless/src/Fig/Bless/TypeChecker.hs deleted file mode 100644 index 2b2cb6d..0000000 --- a/fig-bless/src/Fig/Bless/TypeChecker.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# Language ImplicitParams #-} - -module Fig.Bless.TypeChecker where - -import Fig.Prelude - -import Control.Exception.Safe (Typeable) - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set - -import qualified Data.Aeson as Aeson - -import Fig.Bless.Syntax -import Fig.Bless.Types -import Fig.Bless.Runtime - -data Env m t = Env - { defs :: [(Word, BProgType)] - , ext :: Extractor m t - } - -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) -typeErrorPrefix :: Pretty t => Maybe t -> Text -typeErrorPrefix Nothing = "" -typeErrorPrefix (Just t) = mconcat - [ "while typechecking term: ", pretty t, "\n" - ] - -instance Pretty t => Pretty (TypeError t) where - pretty (TypeErrorWordNotFound t w) = mconcat - [ typeErrorPrefix t - , "word definition not found for: ", pretty w - ] - pretty (TypeErrorMismatch t expected actual) = mconcat - [ typeErrorPrefix t - , "type mismatch:\n" - , "expected: ", pretty expected, "\n" - , "actual: ", pretty actual - ] - pretty (TypeErrorArityMismatch t expected actual) = mconcat - [ typeErrorPrefix t - , "arity mismatch:\n" - , "expected: ", pretty expected, "\n" - , "actual: ", pretty actual - ] - pretty (TypeErrorMixedArray t) = mconcat - [ typeErrorPrefix t - , "array literal has mixed types" - ] - -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 - where - go acc [] = Right acc - go acc ((BTypeVariable v, x):xs) -- ignore variables that are "done", e.g. they don't occur elsewhere - | not (Set.member v (Set.unions $ (typeVariables . fst <$> xs) <> (typeVariables . snd <$> xs))) - = go (Map.insert v x acc) xs - go acc (x:xs) = Left (x, xs <> fmap (first BTypeVariable) (Map.toList acc)) - -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 - -> unifyTypes (zip p0.inp p1.inp <> zip p0.out p1.out <> xs) -- only if the programs have the same arity - | otherwise -> throwM $ TypeErrorArityMismatch ?term p0 p1 -- otherwise, arity mismatch - Left ((t0, t1@(BTypeVariable _)), xs) -> unifyTypes $ (t1, t0):xs -- swap variables to lhs - Left ((t0@(BTypeVariable v), t1), xs) -> unifyTypes -- eliminate - $ (t0, t1):(bimap (substitute v t1) (substitute v t1) <$> xs) - Left ((t0, t1), xs) - | t0 == t1 -> unifyTypes xs -- delete non-variable matches - | otherwise -> throwM $ TypeErrorMismatch ?term t0 t1 -- otherwise, mismatch - -combineProgTypes :: forall m t. Typing m t => BProgType -> BProgType -> m BProgType -combineProgTypes f s' = do - let fvars = typeVariables $ BTypeProgram f - let s = BProgType { inp = ensureUniqueVars fvars <$> s'.inp, out = ensureUniqueVars fvars <$> s'.out } - subst <- unifyTypes $ zip f.out s.inp - let finp = applySubstitution subst <$> f.inp - let fout = applySubstitution subst <$> f.out - let sinp = applySubstitution subst <$> s.inp - let sout = applySubstitution subst <$> s.out - (leftover, dig) <- foldM - ( \(l, d) t -> case l of - x:xs - | x == t -> pure (xs, d) - | otherwise -> throwM $ TypeErrorMismatch ?term t x - [] -> pure (l, d <> [t]) - ) - (fout, []) - sinp - pure BProgType - { inp = finp <> dig - , out = sout <> leftover - } - -typeOfLiteral :: Typing m t => Env m t -> LiteralF t -> m BType -typeOfLiteral _ LiteralInteger{} = pure BTypeInteger -typeOfLiteral _ LiteralDouble{} = pure BTypeDouble -typeOfLiteral _ LiteralString{} = pure BTypeString -typeOfLiteral e (LiteralArray xs) = mapM (typeOfLiteral e) xs >>= \case - [] -> pure $ BTypeArray (BTypeVariable "a") - ts@(t:_) - | length (Set.fromList ts) == 1 -> pure $ BTypeArray t - | otherwise -> throwM $ TypeErrorMixedArray ?term -typeOfLiteral e (LiteralQuote p) = BTypeProgram <$> typeOfProgram e p - -typeOfProgram :: Typing m t => Env m t -> ProgramF t -> m BProgType -typeOfProgram e (Program p) = case p of - ft:ts -> do - x <- typeOf e ft - foldM (\pt t -> let ?term = Just t in combineProgTypes pt =<< typeOf e t) x ts - [] -> pure BProgType {inp = [] , out = []} - -typeOf :: Typing m t => Env m t -> t -> m BProgType -typeOf e wt = do - let ?term = Just wt - e.ext wt >>= \case - TermWord w -> case lookup w e.defs of - Nothing -> throwM $ TypeErrorWordNotFound ?term w - Just p -> pure p - TermLiteral l -> do - out <- typeOfLiteral e l - pure BProgType - { inp = [] - , out = [out] - } - -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) - } - -checkDictionary :: forall m t. Typing m t => Env m t -> DictionaryF t -> m (Env m t) -checkDictionary env d = foldM - ( \e (w, p) -> do - pty <- typeOfProgram e p - pure Env - { ext = e.ext - , defs = (w, pty):e.defs - } - ) - env - d.defs diff --git a/fig-bless/src/Fig/Bless/Types.hs b/fig-bless/src/Fig/Bless/Types.hs deleted file mode 100644 index f7263e7..0000000 --- a/fig-bless/src/Fig/Bless/Types.hs +++ /dev/null @@ -1,84 +0,0 @@ -module Fig.Bless.Types where - -import Fig.Prelude - -import Prelude (error) - -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Set (Set) -import qualified Data.Set as Set - -import qualified Data.Aeson as Aeson - -data BType - = BTypeVariable Text - | BTypeInteger - | BTypeDouble - | BTypeString - | BTypeProgram BProgType - | BTypeArray BType - deriving (Show, Eq, Ord, Generic) -instance Aeson.ToJSON BType -instance Pretty BType where - pretty (BTypeVariable s) = "!" <> s - pretty BTypeInteger = "integer" - pretty BTypeDouble = "double" - pretty BTypeString = "string" - pretty (BTypeProgram p) = "[" <> pretty p <> "]" - pretty (BTypeArray p) = "{" <> pretty p <> "}" - -data BProgType = BProgType - { inp :: [BType] - , out :: [BType] - } - deriving (Show, Eq, Ord, Generic) -instance Aeson.ToJSON BProgType -instance Pretty BProgType where - pretty p = unwords (pretty <$> p.inp) <> " -- " <> unwords (pretty <$> p.out) - -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 - } -renameVars _ x = x - -ensureUniqueVars :: Set Text -> BType -> BType -ensureUniqueVars bad = renameVars \v -> if Set.member v bad - then do - let - names :: [Text] - names = fmap (pack . (:[])) ['a'..'z'] <> fmap (<>"'") names - case headMay $ filter (not . flip Set.member bad) names of - Nothing -> error "unreachable" -- this can't happen because names is an infinite list - Just x -> x - else v - -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 - } -substitute _ _ x = x - -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 - } -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 |