summaryrefslogtreecommitdiff
path: root/fig-bless/src/Fig/Bless
diff options
context:
space:
mode:
Diffstat (limited to 'fig-bless/src/Fig/Bless')
-rw-r--r--fig-bless/src/Fig/Bless/Runtime.hs4
-rw-r--r--fig-bless/src/Fig/Bless/Syntax.hs34
-rw-r--r--fig-bless/src/Fig/Bless/TypeChecker.hs23
-rw-r--r--fig-bless/src/Fig/Bless/Types.hs17
4 files changed, 45 insertions, 33 deletions
diff --git a/fig-bless/src/Fig/Bless/Runtime.hs b/fig-bless/src/Fig/Bless/Runtime.hs
index c1170f3..4de75e0 100644
--- a/fig-bless/src/Fig/Bless/Runtime.hs
+++ b/fig-bless/src/Fig/Bless/Runtime.hs
@@ -153,15 +153,15 @@ 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.Literal -> ValueF t
+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.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 f4dea0a..9cd8aec 100644
--- a/fig-bless/src/Fig/Bless/Syntax.hs
+++ b/fig-bless/src/Fig/Bless/Syntax.hs
@@ -2,7 +2,7 @@
module Fig.Bless.Syntax
( Word(..)
- , Literal(..)
+ , LiteralF(..)
, ProgramF(..)
, Program
, TermF(..)
@@ -10,7 +10,7 @@ module Fig.Bless.Syntax
, DictionaryF(..)
, Dictionary
, Extractor
- , word, literal, termF, term, programF, program, dictionaryF, dictionary, P.eof
+ , word, literalF, termF, term, programF, program, dictionaryF, dictionary, P.eof
, Spanning(..), unSpanning, spanning
, ParseError(..)
, parse
@@ -36,18 +36,20 @@ instance IsString Word where
instance Pretty Word where
pretty (Word t) = t
-data Literal
+data LiteralF t
= LiteralInteger Integer
| LiteralDouble Double
| LiteralString Text
- | LiteralArray [Literal]
- deriving (Show, Eq, Ord, Generic)
-instance Aeson.ToJSON Literal
-instance Pretty Literal where
+ | 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)
@@ -58,14 +60,12 @@ type Program = ProgramF (Fix TermF)
data TermF t
= TermWord Word
- | TermLiteral Literal
- | TermQuote (ProgramF t)
+ | 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
- pretty (TermQuote p) = pretty p
type Term = TermF (Fix TermF)
newtype DictionaryF t = Dictionary
@@ -90,12 +90,12 @@ ws = P.C.L.space
(P.C.L.skipBlockComment "/*" "*/")
wordChar :: Char -> Bool
-wordChar c = not $ elem @[] c ['[', ']', '=', ';'] || isSpace c
+wordChar c = not $ elem @[] c ['[', ']', '{', '}', '=', ';'] || isSpace c
word :: Parser Word
word = Word . pack <$> P.some (P.satisfy wordChar)
-literal :: Parser Literal
-literal =
+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.<|>
@@ -111,8 +111,11 @@ literal =
( (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 '}'))
+ ( (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)
@@ -123,9 +126,8 @@ program = programF $ Fix <$> term
termF :: Parser t -> Parser (TermF t)
termF pt =
- ( P.try (TermLiteral <$> literal)
+ ( P.try (TermLiteral <$> literalF pt)
P.<|> (TermWord <$> word)
- P.<|> (TermQuote <$> (P.C.char '[' *> programF pt <* P.C.char ']'))
) P.<?> "term"
term :: Parser Term
diff --git a/fig-bless/src/Fig/Bless/TypeChecker.hs b/fig-bless/src/Fig/Bless/TypeChecker.hs
index 272d98c..2b2cb6d 100644
--- a/fig-bless/src/Fig/Bless/TypeChecker.hs
+++ b/fig-bless/src/Fig/Bless/TypeChecker.hs
@@ -86,7 +86,9 @@ unifyTypes subst = case completeSubstitution subst of
| otherwise -> throwM $ TypeErrorMismatch ?term t0 t1 -- otherwise, mismatch
combineProgTypes :: forall m t. Typing m t => BProgType -> BProgType -> m BProgType
-combineProgTypes f s = do
+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
@@ -106,15 +108,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
+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
@@ -131,17 +134,11 @@ typeOf e wt = do
Nothing -> throwM $ TypeErrorWordNotFound ?term w
Just p -> pure p
TermLiteral l -> do
- out <- typeOfLiteral l
+ out <- typeOfLiteral e l
pure BProgType
{ inp = []
, out = [out]
}
- TermQuote p -> do
- ty <- typeOfProgram e p
- pure BProgType
- { inp = []
- , out = [BTypeProgram ty]
- }
initializeEnv :: Extractor m t -> Builtins m t -> Env m t
initializeEnv ext bs = Env
diff --git a/fig-bless/src/Fig/Bless/Types.hs b/fig-bless/src/Fig/Bless/Types.hs
index c2e5d41..f7263e7 100644
--- a/fig-bless/src/Fig/Bless/Types.hs
+++ b/fig-bless/src/Fig/Bless/Types.hs
@@ -2,6 +2,8 @@ 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)
@@ -23,8 +25,8 @@ instance Pretty BType where
pretty BTypeInteger = "integer"
pretty BTypeDouble = "double"
pretty BTypeString = "string"
- pretty (BTypeProgram p) = "(" <> pretty p <> ")"
- pretty (BTypeArray p) = "Array<" <> pretty p <> ">"
+ pretty (BTypeProgram p) = "[" <> pretty p <> "]"
+ pretty (BTypeArray p) = "{" <> pretty p <> "}"
data BProgType = BProgType
{ inp :: [BType]
@@ -44,6 +46,17 @@ renameVars f (BTypeProgram p) = BTypeProgram BProgType
}
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-09 13:20:43 +0000