Commit 8ba49771 authored by Gilles Coremans's avatar Gilles Coremans
Browse files

Make code generator functional, minus proper attr handling

parent 5ba53009
{-# LANGUAGE GADTs, KindSignatures, NPlusKPatterns #-}
module Comble where
import qualified Data.Array as A
import Control.Applicative
type Card = Integer
data Comble :: * -> * where
Empty :: Comble e
Pure :: e -> Comble e
Alt :: Comble e -> Comble e -> Card -> Comble e
App :: Comble (arg -> e) -> Comble arg -> Card -> Comble e
card :: Comble e -> Card
card Empty = 0
card (Pure _) = 1
card (Alt _ _ n) = n
card (App _ _ n) = n
instance Functor Comble where
fmap f x = pure f <*> x
instance Applicative Comble where
pure x = Pure x
f <*> x = App f x (card f * card x)
instance Alternative Comble where
empty = Empty
t <|> u = Alt t u (card t + card u)
infixl 9 !
(!) :: Comble e -> Integer -> e
Pure x ! 0 = x
Alt t u _ ! k = if k < m then t ! k else u ! (k - m)
where m = card t
App t u _ ! k = (t ! (k `div` n)) (u ! (k `mod` n))
where n = card u
toList :: Comble e -> [e]
toList c = go c [] where
go Empty acc = acc
go (Pure x) acc = x : acc
go (Alt t u _) acc = go t (go u acc)
go (App (Pure fun) arg _) acc = (fun <$> (toList arg)) ++ acc
go (App fun arg _) acc = ((toList fun) <*> (toList arg)) ++ acc
splitn :: (Integral a) => Integer -> a -> [[a]]
splitn 0 _ = [[0]] -- This function is used to distribute sizes over branches, returning 0 here means only size-0, eg 'empty' can be generated.
splitn 1 x = [[x]]
splitn n x = concatMap (\y -> map (y:) $ splitn (n-1) (x-y)) [1..(x-1)]
asum :: (Alternative effect) => [effect val] -> effect val
asum = foldr (<|>) empty
tabulate :: (A.Ix i) => (i -> e) -> (i,i) -> A.Array i e
tabulate f (l,u) =
A.listArray (l,u) (map f (A.range (l,u)))
......@@ -63,6 +63,11 @@ treesOfSize n = memoGo n where
split2 :: (Integral int) => int -> [(int, int)]
split2 n = [(a, n - a) | a <- [0 .. n]]
splitn :: (Integral a) => Integer -> a -> [[a]]
splitn 0 _ = [[0]] -- This function is used to distribute sizes over branches, returning 0 here means only size-0, eg 'empty' can be generated.
splitn 1 x = [[x]]
splitn n x = concatMap (\y -> map (y:) $ splitn (n-1) (x-y)) [1..(x-1)]
asum :: (Alternative effect) => [effect val] -> effect val
asum = foldr (<|>) empty
......@@ -80,4 +85,4 @@ termsOfSize n = memoGo (n,0) where
go (s+1,m) =
asum [pure (Var v) | v <- [0..m-1]]
<|> (Lam <$> go (s,m+1))
<|> asum [ pure Apply <*> memoGo (s1,m) <*> memoGo (s2, m) | (s1, s2) <- split2 s]
<|> asum [pure Apply <*> memoGo (s1,m) <*> memoGo (s2, m) | (s1, s2) <- split2 s]
......@@ -4,6 +4,7 @@ module Printer.Haskell where
import Data.Text.Prettyprint.Doc
import Data.Maybe
import Data.List
import Program
import Utility
import GeneralTerms
......@@ -29,6 +30,9 @@ instance Pretty Expression where
pretty (EQExpr a b) = parens (pretty a <+> pretty "==" <+> pretty b)
pretty (ListExpr l) = pretty "[" <> hcat (punctuate comma (map pretty l)) <> pretty "]"
pretty (LambdaExpr ps ex) = parens (pretty "\\" <> hsep (map pretty ps) <+> pretty "->" <+> pretty ex)
pretty (AppFnCall n ps) = parens $ hsep $ intersperse (pretty "<*>") ((pretty "pure") <+> (pretty $ lowerFirst n) : map pretty ps)
pretty (AppConstrInst n ps) = parens $ hsep $ intersperse (pretty "<*>") ((pretty "pure") <+> (pretty $ upperFirst n) : map pretty ps)
pretty (AltExpr l r) = parens $ hsep [pretty l, (pretty "<|>") <+> (pretty r)]
instance Pretty Function where
pretty (Fn n lns) = intoLines (map oneLine lns) where
......
......@@ -34,8 +34,9 @@ data Expression
| EQExpr Expression Expression
| ListExpr [Expression]
| LambdaExpr [Parameter] Expression
| AppFnCall Name [Expression] -- <$> and <*> from Applicative typeclass
| AltExpr Expression Expression -- <|> from Alternative typeclass
| AppFnCall Name [Expression] -- <$> and <*> from Applicative typeclass
| AppConstrInst Name [Expression] -- idem
| AltExpr Expression Expression -- <|> from Alternative typeclass
-- | Functions are made up of a name and multiple head (parameter list)
-- and body (expression) pairs
......
......@@ -50,7 +50,7 @@ getVariableInstances (_, hnatc) =
| otherwise = ([ConstrParam n1 [VarParam "h1"], ConstrParam n2 [VarParam "h2"]], FnCall "error" [StringExpr "differing namespace found in compare"])
getVariableFunctions :: Language -> (Type, [Constructor]) -> [Function]
getVariableFunctions lan@(nsd, _, _, _) varT = getHNatModifiers varT ++ getGenerators nsd ++ getShift lan ++ mappingFunctions lan ef ++ substFunctions lan ++ freeVarFunctions lan ef ++ getEnvFunctions lan
getVariableFunctions lan@(nsd, _, _, _) varT = getHNatModifiers varT ++ getGenerators nsd ++ getShift lan ++ mappingFunctions lan ef ++ substFunctions lan ++ freeVarFunctions lan ef ++ getEnvFunctions lan ++ generatorFunctions lan ++ getVarGenFunctions lan
getHNatModifiers :: (Type, [Constructor]) -> [Function]
getHNatModifiers (_, hnatc) =
......@@ -240,59 +240,107 @@ substFunctions (nsd, sd, _, _) =
-- | Generate functions defining a 'Comble', a kind of trie that acts as an enumeration of every possible sort, given a limit on sort size.
generatorFunctions :: Language -> [Function]
generatorFunctions (nsd, sd, _, _) =
let varAccessBySname = varAccessBySortName sd
sortsWithVarAccess = filter (\sort -> fromJust (lookup (sname sort) varAccessBySname)) sd
in concatMap (\s@(MkDefSort sortName ctxs ctors rewrite) ->
[Fn ("gen" ++ sortName)
[(replaceInParams (params s) s (IntParam 1), alternatives sizeOneCtors),
(params s , alternatives sizeNCtors)],
Fn ("get" ++ sortName ++ "vars")
[([ConstrParam (S ++ "")],
)]]
) sortsWithVarAccess
generatorFunctions (nsd, sd, _, _) = concatMap generators sd
where
params s@(MkDefSort name _ _ _) = VarParam "env" : map (\(MkDefSort sname _ _ _) -> VarParam ("n" ++ sname)) sd
replaceInParams params (MkDefSort name _ _ _) replacewith = map (\param -> case param of
(VarParam ("n" ++ name)) = replacewith
_ = param
) params
generators :: SortDef -> [Function]
generators s@(MkDefSort sname ctxs ctors rewrite) =
[Fn ("gen" ++ sname)
[(VarParam "env" : replaceParam s (IntParam 0) params, FnCall "empty" []),
(VarParam "env" : replaceParam s (IntParam 1) params, alternatives $ map genFromCtor $ filter ((== 0) . ctorSize) ctors),
(VarParam "env" : params , alternatives $ map genFromCtor $ filter ((/= 0) . ctorSize) ctors)]]
where
ctorSize :: ConstructorDef -> Int
ctorSize MkVarConstructor{} = 0
ctorSize MkDefConstructor{csorts=sorts} = countSorts sorts s
ctorSize MkBindConstructor{csorts=sorts} = countSorts sorts s
ctorArgs :: Int -> Expression -> [(IdenName, SortName)] -> [Expression]
ctorArgs _ _ [] = []
ctorArgs n env ((_, aname):as) =
if aname == sname
then (FnCall ("gen" ++ aname) $ env:(replaceArg s (FnCall "(!!)" [VarExpr "l", IntExpr n]) args)) : ctorArgs (n+1) env as
else (FnCall ("gen" ++ aname) $ env:(argsOf aname)) : ctorArgs n env as
genFromCtor :: ConstructorDef -> Expression
genFromCtor c@(MkVarConstructor cname cinst) = AppConstrInst cname [FnCall ("get" ++ getNsByInst ctxs cinst) [VarExpr "env", ConstrInst "Z" []]]
genFromCtor c@(MkDefConstructor cname _ csorts _ _ _) = genFromEnvExpression cname csorts (VarExpr "env")
genFromCtor c@(MkBindConstructor cname _ csorts _ (_, ns) _ _) = genFromEnvExpression cname csorts (ConstrInst ("S" ++ ns) [VarExpr "env"])
genFromEnvExpression :: ConstructorName -> [(IdenName, SortName)] -> Expression -> Expression
genFromEnvExpression cname csorts env = if countSorts csorts s > 1
then
FnCall "asum" [FnCall "map"
[LambdaExpr [VarParam "l"] $ AppConstrInst cname $ ctorArgs 0 env csorts,
FnCall "splitn" [IntExpr $ countSorts csorts s, Minus (VarExpr $ "n" ++ sname) (IntExpr 1)]]]
else
AppConstrInst cname $ [FnCall ("gen" ++ aname) $ env:(replaceArg s (Minus (VarExpr $ "n" ++ sname) (IntExpr 1)) $ argsOf aname) | (_, aname) <- csorts]
params = paramsOf sname
args = argsOf sname
getNsByInst :: [Context] -> NamespaceName -> NamespaceName
getNsByInst (ctx:ctxs) inst = if inst == xinst ctx
then xnamespace ctx
else getNsByInst ctxs inst
ctorSize :: ConstructorDef -> SortDef -> Integer
ctorSize MkVarConstructor{} _ = 0
ctorSize MkDefConstructor{csorts=sorts} s = countSorts sorts s
ctorSize MkBindConstructor{csorts=sorts} s = countSorts sorts s
getSortByName :: [SortDef] -> SortName -> SortDef
getSortByName [] _ = undefined
getSortByName (s@MkDefSort{sname=sname}:ss) n = if n == sname
then s
else getSortByName ss n
accessibleSorts :: SortDef -> [SortDef]
accessibleSorts (MkDefSort _ _ ctors _) = go ctors
where go :: [ConstructorDef] -> [SortDef]
go (MkDefConstructor{csorts=sorts} :cs) = (nub $ map (getSortByName sd . snd) sorts) `union` go cs
go (MkBindConstructor{csorts=sorts}:cs) = (nub $ map (getSortByName sd . snd) sorts) `union` go cs
go (MkVarConstructor{} :cs) = go cs
go [] = []
paramsOf :: SortName -> [Parameter]
paramsOf = map (\(MkDefSort sname _ _ _) -> VarParam ("n" ++ sname)) . accessibleSorts . getSortByName sd
argsOf :: SortName -> [Expression]
argsOf = map (\(MkDefSort sname _ _ _) -> VarExpr ("n" ++ sname)) . accessibleSorts . getSortByName sd
replaceParam :: SortDef -> Parameter -> [Parameter] -> [Parameter]
replaceParam (MkDefSort sname _ _ _) replacewith = map $ \p -> case p of (VarParam var) -> if var == "n" ++ sname
then replacewith
else p
_ -> p
replaceArg :: SortDef -> Expression -> [Expression] -> [Expression]
replaceArg (MkDefSort sname _ _ _) replacewith = map $ \a -> case a of (VarExpr var) -> if var == "n" ++ sname
then replacewith
else a
_ -> a
countSorts [] _ = 0
countSorts ((_, name):sorts) s@(MkDefSort sname _ _ _) = (if name == sname
countSorts ((_, name):sorts) s@(MkDefSort sname _ _ _) = (if name == sname
then 1
else 0) + countSorts sorts s
alternatives :: [Expression] -> Expression
alternatives e:[] = e
alternatives e:es = AltExpr e $ alternatives es
mkCtorGen :: ConstructorDef -> SortDef -> Expression
mkCtorGen MkVarConstructor{cname=name, cinst=inst} s@(MkDefSort sname _ _ _) = FnCall ("get" ++ sname ++ "vars") [VarExpr "env"]
alternatives (e:[]) = e
alternatives (e:es) = AltExpr e $ alternatives es
getVarGenFunctions :: Language -> [Function]
getVarGenFunctions (nsd, _, _, _) =
Fn "reverseVar"
Fn "reverseVar"
(([ConstrParam "Z" [], VarParam "res"], VarExpr "res")
: map (MkNameSpace{nname=name, nsort=sort} ->
: map (\MkNameSpace{nname=name, nsort=sort} ->
([ConstrParam ("S" ++ name) [VarParam "next"], VarParam "res"], FnCall "reverseVar" [VarExpr "next", ConstrInst ("S" ++ name) [VarExpr "res"]])
) nsd)
: map (\n ->
let constrName = "S" ++ nname n
funName = "get" ++ nname n
in Fn funName
[([ConstrParam "Z" [] , VarParam "_"] , FnCall "empty" [])
([ConstrParam constrName [VarParam "next"], VarParam "abs"], AltExpr (FnCall "reverseVar" [VarExpr "abs"])
in Fn funName $
[([ConstrParam "Z" [] , VarParam "_"] , FnCall "empty" []),
([ConstrParam constrName [VarParam "next"], VarParam "abs"], AltExpr (FnCall "pure" [FnCall "reverseVar" [VarExpr "abs", ConstrInst "Z" []]])
(FnCall funName [VarExpr "next", ConstrInst constrName [VarExpr "abs"]]))]
++ map (\other ->
let otherCName = "S" ++ nname other
in ([ConstrParam otherCName [VarParam "next"], VarParam "abs"], FnCall funName [VarExpr "next", ConstrInst otherCName [VarExpr "abs"]])
) (filter (/= n) nsd)
++ map (\other ->
let otherCName = "S" ++ nname other
in ([ConstrParam otherCName [VarParam "next"], VarParam "abs"], FnCall funName [VarExpr "next", ConstrInst otherCName [VarExpr "abs"]])
) (filter (/= n) nsd)
) nsd
_getCtorParams :: ConstructorDef -> [Parameter]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment