Commit 19446718 authored by Gilles Coremans's avatar Gilles Coremans
Browse files

Add better support for attrs and natives

parent 8ba49771
......@@ -2,3 +2,5 @@ playground
*.hi
*.o
Tool/autbound
asttool
......@@ -53,7 +53,7 @@ splitn 0 _ = [[0]] -- This function is used to distribute sizes over branches, r
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 :: [Comble val] -> Comble val
asum = foldr (<|>) empty
tabulate :: (A.Ix i) => (i -> e) -> (i,i) -> A.Array i e
......
asttool : Tool/*.hs Tool/*/*.hs
ghc Tool/*.hs Tool/**/*.hs -dynamic -o asttool
clean :
rm Tool/*.o Tool/*.hi Tool/*/*.o Tool/*/*.hi
{-# 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
data Tree elem = Leaf | Node (Tree elem) elem (Tree elem) deriving Show
treesOfSize :: (Alternative effect) => Integer -> effect (Tree ())
treesOfSize n = memoGo n where
table = tabulate go (0,n)
memoGo m = table A.! m where
go 0
= pure Leaf
go (s+1)
= asum [ pure Node <*> memoGo s1 <*> pure () <*> memoGo s2
| (s1, s2) <- split2 s]
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
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)))
data LC = Var Integer | Lam LC | Apply LC LC deriving Show
termsOfSize :: Alternative effect => Integer -> effect LC
termsOfSize n = memoGo (n,0) where
table = tabulate go ((0,0),(n,n))
memoGo p = table A.! p
go (0,m) = asum [pure (Var v) | v <- [0..m-1]]
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]
......@@ -49,7 +49,7 @@ printProgram :: String -> Program -> Doc String
printProgram name program =
intoLines [
printModuleDecl name,
printImports (("Data.List", []) : imports program),
printImports ([("Data.List", []), ("Control.Applicative", []), ("Comble", [])] ++ imports program),
printTypeDecls (types program),
nl,
printFunctions (functions program),
......
......@@ -50,7 +50,8 @@ 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 ++ generatorFunctions lan ++ getVarGenFunctions 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,42 +241,69 @@ 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, _, _) = concatMap generators sd
generatorFunctions (nsd, sd, _, _) =
concatMap generators sd ++ -- Functions to generate the sorts specified
[Fn "genInt" [([], FnCall "asum" [ListExpr [FnCall "pure" [IntExpr n] | n <- [0..3]]])], -- Functions to generate two common natives, ints and strings.
Fn "genString" [([], FnCall "asum" [ListExpr [FnCall "pure" [StringExpr s] | s <- ["a", "b", "c", "d"]]])]]
where
generators :: SortDef -> [Function]
generators s@(MkDefSort sname ctxs ctors rewrite) =
[Fn ("gen" ++ sname)
[Fn ("gen" ++ sname) -- Function that returns a datastructure representing every term of some size.
[(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
(VarParam "env" : params , alternatives $ map genFromCtor $ filter ((/= 0) . ctorSize) ctors)],
Fn (sname ++ "Env") -- Function to 'cast' the contexts of one sort to another by discarding variables not in the target sort's contexts
([([ConstrParam ("S" ++ nsname) [VarParam "next"]],
ConstrInst ("S" ++ nsname) [FnCall (sname ++ "Env") [VarExpr "next"]]) | nsname <- map xnamespace ctxs]
++ [([ConstrParam ("S" ++ nsname) [VarParam "next"]],
FnCall (sname ++ "Env") [VarExpr "next"]) | nsname <- filter (not . flip elem (map xnamespace ctxs)) (map nname nsd)]
++ [([ConstrParam "Z" []],
ConstrInst "Z" [])])]
where
params = paramsOf sname
genFromCtor :: ConstructorDef -> Expression
genFromCtor c@(MkVarConstructor cname cinst) = AppConstrInst cname [FnCall ("get" ++ getNsByInst ctxs cinst) [VarExpr "env", ConstrInst "Z" []]]
genFromCtor c@(MkDefConstructor cname _ csorts _ cattrs natives) = makeRecursiveCtor cname csorts cattrs "" natives
genFromCtor c@(MkBindConstructor cname _ csorts _ (_, ns) cattrs natives) = makeRecursiveCtor cname csorts cattrs ns natives
makeRecursiveCtor :: ConstructorName -> [(IdenName, SortName)] -> [AttributeDef] -> NamespaceName -> [HaskellTypeName] -> Expression
makeRecursiveCtor cname csorts cattrs ns natives =
if countSorts csorts s > 1
then
FnCall "asum" [FnCall "map"
[LambdaExpr [VarParam "l"] $ AppConstrInst cname (ctorArgs 0 ns cattrs csorts ++ nativeArgs),
FnCall "splitn" [IntExpr $ countSorts csorts s, Minus (VarExpr $ "n" ++ sname) (IntExpr 1)]]]
else
AppConstrInst cname ([FnCall ("gen" ++ aname) $
(envFor ns arg cattrs):(replaceArg s (Minus (VarExpr $ "n" ++ sname) (IntExpr 1)) $ argsOf aname) | arg@(_, aname) <- csorts]
++ nativeArgs)
where
nativeArgs = [FnCall ("gen" ++ tname) [] | tname <- natives]
ctorArgs :: Int -> NamespaceName -> [AttributeDef] -> [(IdenName, SortName)] -> [Expression]
ctorArgs _ _ _ [] = []
ctorArgs n ns attrs (arg@(_, aname):as) =
if aname == sname
then (FnCall ("gen" ++ aname) $ env:(replaceArg s (FnCall "(!!)" [VarExpr "l", IntExpr n]) args)) : ctorArgs (n+1) ns attrs as
else (FnCall ("gen" ++ aname) $ env:args) : ctorArgs n ns attrs as
where
env = envFor ns arg attrs
args = argsOf aname
envFor :: NamespaceName -> (IdenName, SortName) -> [AttributeDef] -> Expression
envFor binder (iden, name) allAttrs = FnCall (name ++ "Env") [envexpr attrs]
where
envexpr ((_, RightAdd{}):as) = ConstrInst ("S" ++ binder) [VarExpr "env"]
envexpr (_:as) = envexpr as
envexpr [] = VarExpr "env"
attrs = filter (\(le, _) -> liden le == iden) allAttrs
ctorSize :: ConstructorDef -> Int
ctorSize MkVarConstructor{} = 0
ctorSize MkDefConstructor{csorts=sorts} = countSorts sorts s
ctorSize MkBindConstructor{csorts=sorts} = countSorts sorts s
getNsByInst :: [Context] -> NamespaceName -> NamespaceName
getNsByInst (ctx:ctxs) inst = if inst == xinst ctx
......@@ -290,11 +318,12 @@ generatorFunctions (nsd, sd, _, _) = concatMap generators sd
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 [] = []
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
......
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