{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE StrictData #-}
module Language.TL.AST where
import Data.List.NonEmpty (NonEmpty (..), toList)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import GHC.Generics
import qualified Language.TL.Types as T
type Ann = Maybe Text
type Doc = Map Text Text
class ToTerm a where
toTerm :: a -> Term
class ToType a where
toType :: a -> Type
id2t :: T.Ident -> Text
id2t = T.ident
fid2t :: T.FullIdent -> Text
fid2t (T.FullName ident _) = id2t ident
instance ToType T.Ident where
toType = Type . T.ident
instance ToTerm T.Ident where
toTerm = Var . T.ident
instance ToType T.TypeIdent where
toType (T.Boxed ty) = toType ty
toType (T.LcIdent ident) = toType ident
toType T.NatType = NatType
instance ToTerm T.Term where
toTerm (T.Expr e) = toTerm e
toTerm (T.Type tyIdent) = error "Trying to convert a type into a term"
toTerm (T.Var ident) = toTerm ident
toTerm (T.Nat i) = Nat i
toTerm (T.PTerm t) = toTerm t
toTerm (T.TypeApp ident exprs') =
error "Trying to convert a type application into a term"
instance ToType T.Term where
toType (T.Expr e) = toType e
toType (T.Type tyIdent) = toType tyIdent
toType (T.Var _) = error "Trying to convert a var into a type"
toType (T.Nat _) = error "Trying to convert a nat into a type"
toType (T.PTerm t) = toType t
toType (T.TypeApp tyIdent l) =
let exprs = toList l
in TypeApp (toType tyIdent) (fmap toType exprs)
instance ToTerm T.SubExpr where
toTerm (T.Sum ((Right t) :| [])) = toTerm t
toTerm _ = error "subExpr is not a term"
instance ToType T.SubExpr where
toType (T.Sum ((Right t) :| [])) = toType t
toType _ = error "subExpr is not a term"
instance ToTerm T.Expr where
toTerm (T.Exprs exprs) =
let h = head exprs
t = tail exprs
in App (toTerm h) (fmap toTerm t)
instance ToType T.Expr where
toType (T.Exprs subexprs) =
let h = head subexprs
t = tail subexprs
in TypeApp (toType h) (fmap toType t)
instance ToType T.ResultType where
toType (T.RTypeApp ident subExprs) =
if null subExprs
then toType ident
else TypeApp (toType ident) (fmap toType subExprs)
combConv :: Doc -> T.CombinatorDecl -> Combinator
combConv doc T.CombinatorDecl {..} =
if null optArglist
then case combId of
T.Optional fid ->
let ident = fid2t fid
in Combinator
{ args = argsList >>= argsConv doc,
resType = toType resType,
ann = M.lookup "description" doc,
..
}
T.Omitted -> error "top level combinator with omitted "
else error ""
combConv _ T.BuiltinDecl {} = error "builtin decl"
argsConv :: Doc -> T.Args -> [Arg]
argsConv doc (T.Named (T.Optional id) _ _ t) =
let ident = id2t id
in pure $ Arg ident (M.lookup ident doc) (toType t)
argsConv _ T.Named {} = error "unnamed argument"
argsConv _ T.MultipleArgs {} = error "multiplicity"
argsConv doc (T.NamedList l _ t) =
let ids = toList l
in fmap
( \case
T.Optional id ->
let ident = id2t id
in Arg ident (M.lookup ident doc) (toType t)
_ -> error "uunamed argument"
)
ids
argsConv _ T.Unnamed {} = error "unnamed argument"
data Combinator
= Combinator
{ ident :: Text,
ann :: Maybe Text,
args :: [Arg],
resType :: Type
}
deriving (Show, Eq, Generic)
combArity :: Combinator -> Int
combArity Combinator {..} =
case resType of
Type _ -> 0
NatType -> error "result type is NatType"
TypeApp _ param -> length param
combName :: Combinator -> Text
combName Combinator {..} =
case resType of
Type t -> t
NatType -> error "result type is NatType"
TypeApp (Type t) _ -> t
TypeApp _ _ -> error "combinator is not an ADT"
data ADT
= ADT
{ name :: Text,
ann :: Ann,
constructors :: [Combinator]
}
deriving (Show, Eq, Generic)
newtype Function
= Function Combinator
deriving (Show, Eq, Generic)
data Type
= Type Text
| TypeApp Type [Type]
| NatType
deriving (Show, Eq, Generic)
data Term
= Var Text
| Nat Int
| App Term [Term]
deriving (Show, Eq, Generic)
data Arg
= Arg
{ argName :: Text,
ann :: Ann,
argType :: Type
}
deriving (Show, Eq, Generic)