Add fig-bless

4 files changed, 398 insertions, 0 deletions

diff --git a/fig-bless/src/Fig/Bless/Builtins.hs b/fig-bless/src/Fig/Bless/Builtins.hs
new file mode 100644
index 0000000..2072ea9
--- /dev/null
+++ b/fig-bless/src/Fig/Bless/Builtins.hs
@@ -0,0 +1,82 @@
+{-# Language ImplicitParams #-}
+
+module Fig.Bless.Builtins
+  ( arithmetic
+  ) where
+
+import Fig.Prelude
+
+import Control.Monad.State.Strict (execStateT, StateT)
+
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+
+import qualified Fig.Bless.Syntax as Syn
+import Fig.Bless.Runtime
+
+-- * Helper functions
+stateful :: Running m t v => StateT (VM m t v) m a -> Builtin m t v
+stateful = execStateT
+
+push :: (Running m t v, MonadState (VM m' t v) m) => ValueF t v -> 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 = 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
+int (ValueInteger i) = pure i
+int v = throwM $ RuntimeErrorSortMismatch ?term ValueSortInteger (valueSort v)
+
+double :: Running m t v => ValueF t v -> 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 (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 (ValueProgram p) = pure p
+program v = throwM $ RuntimeErrorSortMismatch ?term ValueSortProgram (valueSort v)
+
+array :: Running m t v => ValueF t v -> m [v]
+array (ValueArray a) = pure a
+array v = throwM $ RuntimeErrorSortMismatch ?term ValueSortProgram (valueSort v)
+
+-- * Arithmetic builtins
+add :: Running m t v => Builtin m t v
+add = stateful do
+  y <- int =<< pop
+  x <- int =<< pop
+  push . ValueInteger $ x + y
+
+mul :: Running m t v => Builtin m t v
+mul = stateful do
+  y <- int =<< pop
+  x <- int =<< pop
+  push . ValueInteger $ x * y
+
+sub :: Running m t v => Builtin m t v
+sub = stateful do
+  y <- int =<< pop
+  x <- int =<< pop
+  push . ValueInteger $ x - y
+
+div :: Running m t v => Builtin m t v
+div = stateful 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
+  [ ("+", add)
+  , ("*", mul)
+  , ("-", sub)
+  , ("/", div)
+  ]
diff --git a/fig-bless/src/Fig/Bless/Runtime.hs b/fig-bless/src/Fig/Bless/Runtime.hs
new file mode 100644
index 0000000..8a07e8e
--- /dev/null
+++ b/fig-bless/src/Fig/Bless/Runtime.hs
@@ -0,0 +1,148 @@
+{-# Language ImplicitParams #-}
+
+module Fig.Bless.Runtime
+  ( ValueF(..), Value
+  , ValueSort(..), valueSort
+  , RuntimeError(..)
+  , RunningTop, Running
+  , Builtin, Builtins
+  , Extractor
+  , 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 Fig.Bless.Syntax as Syn
+
+data ValueF t v
+  = ValueInteger Integer
+  | ValueDouble Double
+  | ValueString Text
+  | ValueWord Syn.Word
+  | ValueProgram (Syn.ProgramF t)
+  | ValueArray [v]
+  deriving (Show, Eq, Ord)
+instance (Pretty t, Pretty v) => Pretty (ValueF t v) where
+  pretty (ValueInteger i) = tshow i
+  pretty (ValueDouble d) = tshow d
+  pretty (ValueString s) = tshow s
+  pretty (ValueWord s) = pretty s
+  pretty (ValueProgram p) = pretty p
+  pretty (ValueArray vs) = mconcat
+    [ "["
+    , Text.intercalate ", " $ pretty <$> vs
+    , "]"
+    ]
+type Value = ValueF (Fix Syn.TermF) (Fix (ValueF (Fix Syn.TermF)))
+
+data ValueSort
+  = ValueSortInteger
+  | ValueSortDouble
+  | ValueSortString
+  | ValueSortWord
+  | ValueSortProgram
+  | ValueSortArray
+  deriving (Show, Eq, Ord)
+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 v -> ValueSort
+valueSort (ValueInteger _) = ValueSortInteger
+valueSort (ValueDouble _) = ValueSortDouble
+valueSort (ValueString _) = ValueSortString
+valueSort (ValueWord _) = ValueSortWord
+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)
+instance (Show t, Typeable t) => Exception (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 v = (MonadThrow m, Typeable t, Show t)
+type Running m t v = (RunningTop m t v, ?term :: Maybe t)
+type Builtin m t v = VM m t v -> m (VM m t v)
+type Builtins m t v = Maybe t -> Map Syn.Word (Builtin m t v)
+type Extractor m t = t -> m (Syn.TermF t)
+data VM m t v = VM
+  { fuel :: Maybe Integer
+  , bindings :: Syn.DictionaryF t
+  , builtins :: Builtins m t v
+  , stack :: [ValueF t v]
+  }
+
+initialize :: Running m t v => Maybe Integer -> Syn.DictionaryF t -> Builtins m t v -> VM m t v
+initialize fuel bindings builtins = VM{..}
+  where
+    stack = []
+
+checkFuel :: Running m t v => VM m t v -> m (VM m t v)
+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 v => ValueF t v -> VM m t v -> VM m t v
+push v vm = vm
+  { stack = v : vm.stack
+  }
+
+runProgram :: Running m t v => Extractor m t -> Syn.ProgramF t -> VM m t v -> m (VM m t v)
+runProgram f (Syn.Program p) vm = foldM (flip (run f)) vm p
+
+runWord :: Running m t v => Extractor m t -> Syn.Word -> VM m t v -> m (VM m t v)
+runWord _ w vm | Just b <- Map.lookup w $ vm.builtins ?term = b vm
+runWord f w vm | Just p <- Map.lookup w vm.bindings.defs = runProgram f p vm
+runWord _ w _ = throwM $ RuntimeErrorWordNotFound ?term w
+
+run :: Running m t v => Extractor m t -> t -> VM m t v -> m (VM m t v)
+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.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
new file mode 100644
index 0000000..ca592f5
--- /dev/null
+++ b/fig-bless/src/Fig/Bless/Syntax.hs
@@ -0,0 +1,167 @@
+{-# Language ApplicativeDo #-}
+
+module Fig.Bless.Syntax
+  ( Word(..)
+  , Literal(..)
+  , ProgramF(..)
+  , Program
+  , TermF(..)
+  , Term
+  , DictionaryF(..)
+  , Dictionary
+  , word, literal, termF, term, programF, program, dictionaryF, dictionary, P.eof
+  , Spanning(..), unSpanning, spanning
+  , ParseError(..)
+  , parse
+  ) where
+
+import Fig.Prelude
+
+import Data.Char (isSpace)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Functor ((<&>))
+import Data.Text (unlines)
+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
+
+newtype Word = Word Text
+  deriving (Show, Eq, Ord)
+instance IsString Word where
+  fromString = Word . fromString
+instance Pretty Word where
+  pretty (Word t) = t
+
+data Literal
+  = LiteralInteger Integer
+  | LiteralDouble Double
+  | LiteralString Text
+  deriving (Show, Eq, Ord)
+instance Pretty Literal where
+  pretty (LiteralInteger i) = tshow i
+  pretty (LiteralDouble d) = tshow d
+  pretty (LiteralString s) = tshow s
+
+newtype ProgramF t = Program [t]
+  deriving (Show, Eq, Ord, Functor)
+instance Pretty t => Pretty (ProgramF t) where
+  pretty (Program ts) = unwords $ pretty <$> ts
+type Program = ProgramF (Fix TermF)
+
+data TermF t
+  = TermWord Word
+  | TermLiteral Literal
+  | TermQuote (ProgramF t)
+  deriving (Show, Eq, Ord, Functor)
+instance Pretty t => Pretty (TermF t) where
+  pretty (TermWord w) = pretty w
+  pretty (TermLiteral l) = pretty l
+  pretty (TermQuote p) = pretty p
+type Term = TermF (Fix TermF)
+
+newtype DictionaryF t = Dictionary
+  { defs :: Map Word (ProgramF t)
+  } deriving (Show, Eq, Ord)
+instance Pretty t => Pretty (DictionaryF t) where
+  pretty d = unlines $ Map.toList d.defs <&> \(w, p) -> mconcat
+    [ pretty w
+    , " = "
+    , pretty p
+    ]
+type Dictionary = DictionaryF (Fix TermF)
+
+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)
+
+literal :: Parser Literal
+literal =
+  (
+    ( 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.<|>
+  ( (LiteralDouble <$> P.C.L.signed (pure ()) P.C.L.float)
+    P.<?> "floating-point literal"
+  ) P.<|>
+  ( (LiteralString . pack <$> (P.C.char '"' *> P.manyTill P.C.L.charLiteral (P.C.char '"')))
+    P.<?> "string literal"
+  )
+
+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 <$> literal)
+    P.<|> (TermWord <$> word)
+    P.<|> (TermQuote <$> (P.C.char '[' *> programF pt <* P.C.char ']'))
+  ) P.<?> "term"
+
+term :: Parser Term
+term = termF $ Fix <$> term
+
+dictionaryF :: Parser t -> Parser (DictionaryF t)
+dictionaryF pt = Dictionary . Map.fromList <$> 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
+instance Exception ParseError
+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)
+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/Types.hs b/fig-bless/src/Fig/Bless/Types.hs
new file mode 100644
index 0000000..219dc48
--- /dev/null
+++ b/fig-bless/src/Fig/Bless/Types.hs
@@ -0,0 +1 @@
+module Fig.Bless.Types where