module Bricks.ExpressionToTerm where
import Bricks.BuiltinFunctions
import Bricks.Expression
import Bricks.Term
import Bricks.Type
import qualified Bricks.Internal.List as List
import Bricks.Internal.Prelude
import qualified Bricks.Internal.Seq as Seq
import Bricks.Internal.Text (Text)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Control.Applicative (liftA2)
import System.IO (IO)
expression'to'term :: Expression -> IO Term
expression'to'term =
\case
Expr'Var x -> var'to'term x
Expr'Str x -> str'to'term x
Expr'Str'Indented x -> str'to'term (inStr'to'strDynamic x)
Expr'List x -> list'to'term x
Expr'Dict x -> dict'to'term x
Expr'Dot x -> dot'to'term x
Expr'Lambda x -> lambda'to'term x
Expr'Apply x -> apply'to'term x
Expr'Let x -> let'to'term x
var'to'term :: Var -> IO Term
var'to'term = pure . Term'Var . var'text
apply'to'term :: Apply -> IO Term
apply'to'term x =
do
a <- expression'to'term (apply'func x)
b <- expression'to'term (apply'arg x)
pure $ a /@\ b
str'to'term :: Str'Dynamic -> IO Term
str'to'term x =
case Seq.toList (strDynamic'toSeq x) of
[] -> pure $ term'data type'string ""
ys -> foldr1 (liftA2 f) $ fmap str'1'to'term ys
where
f a b = fn'string'append /@@\ (a, b)
str'1'to'term :: Str'1 -> IO Term
str'1'to'term = \case
Str'1'Literal x -> pure $ term'data type'string (str'static'text x)
Str'1'Antiquote x -> expression'to'term x
list'to'term :: List -> IO Term
list'to'term x =
Term'List <$> traverse expression'to'term (list'expressions x)
dict'to'term :: Dict -> IO Term
dict'to'term = undefined
dot'to'term :: Dot -> IO Term
dot'to'term x =
do
a <- expression'to'term (dot'dict x)
b <- expression'to'term (dot'key x)
pure $ fn'dict'lookup /@@\ (a, b)
let'to'term :: Let -> IO Term
let'to'term x =
Term'LetRec <$> bindings <*> body
where
bindings :: IO (Map Text Term)
bindings =
Map.fromList . List.concat <$>
traverse letBinding'to'term (let'bindings x)
body :: IO Term
body =
expression'to'term $ let'value x
letBinding'to'term :: LetBinding -> IO [(Text, Term)]
letBinding'to'term =
\case
LetBinding'Eq a b ->
do
b' <- expression'to'term b
pure [(var'text a, b')]
LetBinding'Inherit d xs ->
do
p <- newTermPtr =<< expression'to'term d
pure
$ fmap (\x ->
( var'text x
, fn'dict'lookup /@@\ (p, term'data type'string (var'text x))
))
$ Seq.toList xs
lambda'to'term :: Lambda -> IO Term
lambda'to'term x =
do
body <- expression'to'term (lambda'body x)
case lambda'head x of
Param'Name var -> lambda'to'term'simple var body
Param'DictPattern dp -> lambda'to'term'dictPattern dp body
Param'Both var dp -> lambda'to'term'both var dp body
lambda'to'term'simple :: Var -> Term -> IO Term
lambda'to'term'simple var body =
pure $ TermPattern'Simple (var'text var) |-> body
lambda'to'term'dictPattern :: DictPattern -> Term -> IO Term
lambda'to'term'dictPattern dp body = do
let names = dictPattern'names dp
let h = if dictPattern'ellipsis dp then fn'id
else fn'dict'disallowExtraKeys names
defs <- dictPattern'defaults dp
let g = fn'dict'merge'preferLeft /@\ Term'Dict'ReducedKeys defs
let f = TermPattern'Dict names |-> body
pure $ fn'comp /@@\ (fn'comp /@@\ (f, g), h)
lambda'to'term'both :: Var -> DictPattern -> Term -> IO Term
lambda'to'term'both var dp body =
lambda'to'term'simple var =<< lambda'to'term'dictPattern dp body
dictPattern'names :: DictPattern -> Set Text
dictPattern'names (DictPattern xs _) =
Set.fromList . fmap f . Seq.toList $ xs
where
f = var'text . dictPattern'1'name
dictPattern'defaults :: DictPattern -> IO (Map Text Term)
dictPattern'defaults (DictPattern xs _) =
Map.fromList . catMaybes <$> traverse f (Seq.toList xs)
where
f :: DictPattern'1 -> IO (Maybe (Text, Term))
f x =
case dictPattern'1'default x of
Nothing -> pure Nothing
Just d ->
do
a <- expression'to'term d
pure $ Just (var'text (dictPattern'1'name x), a)