1 files changed, 167 insertions, 0 deletions
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