Permalink
Browse files

Merge branch 'master' of https://github.com/mpu/dedukti

Conflicts:
	Dedukti/Runtime.hs
  • Loading branch information...
2 parents 0a3b2a9 + 55753a6 commit cd91c35570775bd6be83c766d4c9640986a50fff @mboes committed Apr 4, 2012
View
@@ -0,0 +1,2 @@
+*.sw[po]
+dist
View
@@ -12,7 +12,8 @@ import Dedukti.DkM
import qualified Dedukti.Rule as Rule
import Dedukti.Pretty ()
import Text.PrettyPrint.Leijen hiding (group)
-import Data.List (group, sort)
+import Data.List (group, groupBy, sort)
+import Data.Function (on)
newtype NonContiguousRules = NonContiguousRules Qid
@@ -32,6 +33,24 @@ checkOrdering rules = do
mapM_ (\x -> when (length x > 1) (throw $ NonContiguousRules (head x))) $
group $ sort $ map head $ group $ map Rule.headConstant rules
+newtype BadArity = BadArity Qid
+ deriving (Eq, Ord, Typeable)
+
+instance Show BadArity where
+ show (BadArity id) =
+ show (text "Some rules for" <+> pretty id <+> text "have different arities.")
+
+instance Exception BadArity
+
+-- | All rules for one constant must have the same arity.
+checkArity :: [TyRule Qid a] -> DkM ()
+checkArity rules = do
+ say Verbose $ text "Checking arity of rules ..."
+ mapM_ (\(l:ls) -> chk (Rule.headConstant l) (napps (Rule.head l)) ls)
+ $ groupBy ((==) `on` Rule.headConstant) rules
+ where chk id n l = when (or (map ((/=) n . napps . Rule.head) l)) (throw $ BadArity id)
+ napps e = unapply e (\_ x _ -> length x)
+
newtype BadPattern = BadPattern [Qid]
deriving (Eq, Ord, Typeable)
@@ -14,6 +14,7 @@ import qualified Dedukti.Rule as Rule
import Dedukti.Pretty ()
import Dedukti.DkM
import Data.List (sort, group)
+import qualified Data.Traversable as T
import qualified Data.Map as Map
import qualified StringTable.AtomSet as AtomSet
@@ -71,7 +72,9 @@ checkScopes env (decls, rules) = do
(AtomSet.singleton (qid_stem qid)) env
notmem qid env = maybe False (AtomSet.notMember (qid_stem qid))
(Map.lookup (qid_qualifier qid) env)
- chkBinding env (L x) = return $ ins x env
+ chkBinding env (L x ty) = do
+ chkExpr env `T.mapM` ty
+ return $ ins x env
chkBinding env (x ::: ty) = do
chkExpr env ty
return $ ins x env
@@ -87,7 +90,8 @@ checkScopes env (decls, rules) = do
chkExpr env t@(V x _) = do
when (x `notmem` env) (throw $ ScopeError x)
return t
- chkExpr env (B (L x) t _) = do
+ chkExpr env (B (L x ty) t _) = do
+ chkExpr env `T.mapM` ty
chkExpr (ins x env) t
chkExpr env (B (x ::: ty) t _) = do
chkExpr env ty
View
@@ -43,16 +43,16 @@ instance CodeGen Record where
data Bundle Record = Bundle [Hs.Decl]
emit rs@(RS x ty rules) =
- Rec x (length rules) (function rs : def_ty : def_box : zipWith defs_rule [0..] rules)
- where (tyname, boxname) = (varName (x .$ "ty"), varName (x .$ "box"))
+ Rec x (length rules) (def_ty : function rs : def_t : zipWith defs_rule [0..] rules)
+ where [tyname, tname, cname] = map (varName . (x .$)) ["ty", "t", "c"]
def_ty = [dec| ((tyname)) = $(code ty) |]
- def_box = [dec| ((boxname)) = bbox $(term ty) $(Hs.var tyname) $(var x) |]
+ def_t = [dec| ((tname)) = bbox $(term ty) $(Hs.var tyname) $(Hs.var cname) |]
-- Checking rules involves much of the same work as checking all
-- declarations at top-level, so let's just call the code
-- generation functions recursively.
defs_rule n (env :@ lhs :--> rhs) =
let f (x ::: ty) rs = (emit (RS x ty []) :: Record) : rs
- ruleCheck = let rule_box = varName (qid "rule" .$ "box")
+ ruleCheck = let rule_box = varName (qid "rule" .$ "t")
in Rec (qid "rule") 0 [[dec| ((rule_box)) = checkRule $(term lhs) $(term rhs) |]]
Bundle decls = coalesce $ foldr f [ruleCheck] (env_bindings env)
rule = varName (x .$ "rule" .$ B.pack (show n))
@@ -63,7 +63,7 @@ instance CodeGen Record where
where main = [dec| main = $checks |]
checks = Hs.Do (concatMap rules records ++ map declaration records)
declaration r = let desc = Hs.strE $ show $ pretty $ unqualify $ rec_name r
- in Hs.qualStmt [hs| checkDeclaration $desc $(var (rec_name r .$ "box")) |]
+ in Hs.qualStmt [hs| checkDeclaration $desc $(var (rec_name r .$ "t")) |]
rules (Rec _ 0 _) = []
rules (Rec x nr _) =
let startmsg = Hs.strE $ "Starting rule " ++ show (pretty (unqualify x)) ++ "."
@@ -73,7 +73,7 @@ instance CodeGen Record where
++ [Hs.qualStmt [hs| putStrLn $finishmsg |]]
serialize mod deps (Bundle decls) =
- B.pack $ prettyPrintWithMode defaultMode {layout = PPInLine} $
+ B.pack $ prettyPrintWithMode defaultMode {layout = PPOffsideRule} $
Hs.Module (*) (modname mod) [] Nothing Nothing imports decls
where imports = runtime : map (\m -> Hs.ImportDecl (*) (modname m) True False Nothing Nothing Nothing) deps
runtime = Hs.ImportDecl (*) (Hs.ModuleName "Dedukti.Runtime") False False Nothing Nothing Nothing
@@ -100,8 +100,8 @@ xencode qid =
| otherwise = B.singleton x
function :: Em RuleSet -> Hs.Decl
-function (RS x _ []) = Hs.nameBind (*) (varName x) (constant x)
-function (RS x _ rs) = Hs.sfun (*) (varName x) [] (Hs.UnGuardedRhs rhs) (Hs.binds [f])
+function (RS x _ []) = Hs.nameBind (*) (varName (x .$ "c")) (constant x)
+function (RS x _ rs) = Hs.sfun (*) (varName (x .$ "c")) [] (Hs.UnGuardedRhs rhs) (Hs.binds [f])
where n = Rule.arity (head rs)
pats = Stream.take n variables
occs = map Hs.var pats
@@ -117,9 +117,9 @@ clause rule =
Nothing (Hs.UnGuardedRhs (code rhs)) Hs.noBinds
else Hs.Match (*) (Hs.name "__") (map (pattern env) (Rule.patterns lrule))
Nothing (Hs.GuardedRhss [Hs.GuardedRhs (*) (guards constraints) (code rhs)]) Hs.noBinds
- where guards = map (\(x, x') -> Hs.qualStmt $
- [hs| reflect (convertible 0 $(var x) $(var x')) |])
- qids = Stream.unfold (\i -> ((qid $ B.pack $ show i) .$ "fresh", i + 1)) 0
+ where guards = let tt = Hs.pApp (Hs.name "()") []
+ in map (\(x, x') -> Hs.Generator (*) tt [hs| convertible 0 $(var (x .$ "c")) $(var (x' .$ "c")) |])
+ qids = Stream.unfold (\i -> ((qid $ B.pack $ show i) .$ "fresh" .$ "c", i + 1)) 0
defaultClause :: Id Record -> Int -> Hs.Match
defaultClause x n =
@@ -129,7 +129,7 @@ defaultClause x n =
constant c = [hs| Con $(Hs.strE $ show $ pretty c) |]
pattern :: Em Env -> Em Expr -> Hs.Pat
-pattern env (V x _) | x `isin` env = Hs.pvar (varName x)
+pattern env (V x _) | x `isin` env = Hs.pvar (varName (x .$ "c"))
pattern env expr = unapply expr (\(V x _) xs _ -> primAppsP x (map (pattern env) xs))
-- | Build a pattern matching constant.
@@ -139,26 +139,32 @@ primAppsP c = foldl' primAppP (primConP c)
-- | Turn an expression into object code with types erased.
code :: Em Expr -> Hs.Exp
-code (B (L x) t _) | n <- varName x = [hs| Lam (\((n)) -> $(code t)) |]
-code (B (x ::: ty) t _) | n <- varName x = [hs| Pi $(code ty) (\((n)) -> $(code t)) |]
-code (B (x := t1) t2 _) | n <- varName x = [hs| let ((n)) = $(code t1) in $(code t2) |]
+code (V x _) = var (x .$ "c")
+code (B (L x _) t _) | n <- varName (x .$ "c") = [hs| Lam (\((n)) -> $(code t)) |]
+code (B (x ::: ty) t _) | n <- varName (x .$ "c") = [hs| Pi $(code ty) (\((n)) -> $(code t)) |]
+code (B (x := t1) t2 _) | n <- varName (x .$ "c") = [hs| let ((n)) = $(code t1) in $(code t2) |]
code (A t1 t2 _) = [hs| ap $(code t1) $(code t2) |]
-code (V x _) = var x
code Type = [hs| Type |]
-- | Turn a term into its Haskell representation, including all types.
term :: Em Expr -> Hs.Exp
-term (B (L x) t _) | n <- varName (x .$ "box") = [hs| TLam (\((n)) -> $(term t)) |]
-term (B (x ::: ty) t _) = typedAbstraction [hs| TPi |] x ty (term t)
-term (B (x := t1) t2 _) | n <- varName (x .$ "box") = [hs| TLet $(term t1) (\((n)) -> $(term t2)) |]
-term (A t1 t2 _) = [hs| TApp $(term t1) $(term t2) |]
-term (V x _) = var (x .$ "box")
+term (V x _) = var (x .$ "t")
+term (B (L x ty) t _) = lambdaAbstraction x ty (term t)
+term (B (x ::: ty) t _) = typedAbstraction x ty (term t)
+term (B (x := t1) t2 _) = letBinding x t1 (term t2)
+term (A t1 t2 _) = [hs| TApp $(term t1) (Pair $(term t2) $(code t2)) |]
term Type = [hs| TType |]
-typedAbstraction c x ty t = [hs| $c $(dom ty) (\((box)) -> $ran) |]
- where box = varName (x .$ "box")
- ran = let n = varName x
- in [hs| let ((n)) = obj $(Hs.var box) in $t |]
+letBinding x t1 t = [hs| TLet (Pair $(term t1) $(code t1)) (\(Pair ((xt)) ((xc))) -> $t) |]
+ where (xt, xc) = (varName (x .$ "t"), varName (x .$ "c"))
+
+lambdaAbstraction x ty t = [hs| TLam $tyterm (\(Pair ((xt)) ((xc))) -> $t) |]
+ where (xt, xc) = (varName (x .$ "t"), varName (x .$ "c"))
+ tyterm = case ty of Nothing -> [hs| Nothing |]
+ Just ty -> [hs| Just $ sbox $(term ty) Type $(code ty) |]
+
+typedAbstraction x ty t = [hs| TPi $(dom ty) (\(Pair ((xt)) ((xc))) -> $t) |]
+ where (xt, xc) = (varName (x .$ "t"), varName (x .$ "c"))
dom ty = if isVariable ty
then term ty else [hs| sbox $(term ty) Type $(code ty) |]
View
@@ -30,6 +30,7 @@ module Dedukti.Core
import Control.Applicative
import Control.Monad.Identity
import Control.Monad.State
+import qualified Data.Traversable as T
import qualified Data.Map as Map
@@ -44,9 +45,9 @@ infix 2 :::
-- | A type decorating a variable, a type on its own, or an expression
-- defining a variable
-data Binding id a = L id -- ^ Lambda binding
- | id ::: Expr id a -- ^ Pi binding
- | id := Expr id a -- ^ Let binding
+data Binding id a = L id (Maybe (Expr id a)) -- ^ Lambda binding
+ | id ::: Expr id a -- ^ Pi binding
+ | id := Expr id a -- ^ Let binding
deriving (Eq, Ord, Show)
-- | A rewrite rule.
@@ -82,6 +83,7 @@ type family Id t
type family A t
type instance Id [t] = Id t
+type instance Id (Maybe t) = Id t
type instance Id (Module id a) = id
type instance Id (Binding id a) = id
type instance Id (Rule id a) = id
@@ -90,6 +92,7 @@ type instance Id (RuleSet id a) = id
type instance Id (Expr id a) = id
type instance A [t] = A t
+type instance A (Maybe t) = A t
type instance A (Module id a) = a
type instance A (Binding id a) = a
type instance A (Rule id a) = a
@@ -98,13 +101,13 @@ type instance A (RuleSet id a) = a
type instance A (Expr id a) = a
bind_name :: Binding id a -> id
-bind_name (L x) = x
+bind_name (L x _) = x
bind_name (x ::: _) = x
bind_name (x := _) = x
-- | A lambda or Pi abstraction.
isAbstraction :: Expr id a -> Bool
-isAbstraction (B (L _) _ _) = True
+isAbstraction (B (L _ _) _ _) = True
isAbstraction (B (_ ::: _) _ _) = True
isAbstraction _ = False
@@ -186,7 +189,6 @@ abstract :: [Binding id a] -> Expr id a -> [a] -> Expr id a
abstract [] t _ = t
abstract (b:bs) t (a:annots) = B b (abstract bs t annots) %% a
abstract bs _ as = error $ "abstract: " ++ show (length bs) ++ " bindings but only "
- ++ show (length as) ++ " annotations."
unabstract :: Expr id a -> ([Binding id a] -> Expr id a -> [a] -> r) -> r
unabstract (B b t a) k = unabstract t (\bs t' as -> k (b:bs) t' (a:as))
@@ -205,7 +207,6 @@ unapply t k = go [] [] t where
go xs as (A t1 t2 a) = go (t2:xs) (a:as) t1
go xs as t = k t xs as
-
class Ord (Id t) => Transform t where
-- | Effectful bottom-up transformation on terms. A default for
-- 'transformM' in terms of 'descendM' for all instances other than
@@ -218,17 +219,17 @@ class Ord (Id t) => Transform t where
instance Ord id => Transform (Module id a) where
descendM f (decls, rules) =
- return (,) `ap` mapM (descendM f) decls `ap` mapM (descendM f) rules
+ return (,) `ap` descendM f decls `ap` descendM f rules
instance Ord id => Transform (Binding id a) where
- descendM f (L x) = return (L x)
+ descendM f (L x t) = return (L x) `ap` T.mapM f t
descendM f (x ::: ty) = return (x :::) `ap` f ty
descendM f (x := t) = return (x :=) `ap` f t
instance Ord id => Transform (TyRule id a) where
descendM f (env :@ rule) =
- return (:@) `ap` (return fromBindings `ap` mapM (descendM f) (env_bindings env)) `ap`
- descendM f rule
+ return (:@) `ap` (return fromBindings `ap` descendM f (env_bindings env))
+ `ap` descendM f rule
instance Ord id => Transform (Rule id a) where
descendM f (lhs :--> rhs) = return (:-->) `ap` f lhs `ap` f rhs
@@ -238,18 +239,17 @@ instance Ord id => Transform (RuleSet id a) where
return RS `ap` return rs_name `ap` f rs_type `ap` descendM f rs_rules
instance Ord id => Transform (Expr id a) where
- transformM f = f <=< descendM (transformM f)
-
- descendM f (B b t a) = do
- t' <- f t
- b' <- descendM f b
- return $ B b' t' a
- descendM f (A t1 t2 a) = do
- return A `ap` f t1 `ap` f t2 `ap` return a
+ transformM f = descendM (transformM f) >=> f
+
+ descendM f (B b t a) = return B `ap` descendM f b `ap` f t `ap` return a
+ descendM f (A t1 t2 a) = return A `ap` f t1 `ap` f t2 `ap` return a
descendM f t = return t
instance Transform t => Transform [t] where
- descendM f = mapM (descendM f)
+ descendM f = T.mapM (descendM f)
+
+instance Transform a => Transform (Maybe a) where
+ descendM f = T.mapM (descendM f)
-- | Pure bottom-up transformation on terms.
transform :: Transform t => (Expr (Id t) (A t) -> Expr (Id t) (A t)) -> t -> t
@@ -36,8 +36,8 @@ selfQualify mod rsets = let defs = Set.fromList (map rs_name rsets)
(map (\RS{..} -> RS{rs_name = qualify mod rs_name, ..}) rsets)
where f defs (V x a) | Nothing <- provenance x
, x `Set.member` defs = V (qualify mod x) %% a
- f defs (B (L x) t a) =
- B (L x) (f (Set.delete x defs) t) %% a
+ f defs (B (L x ty) t a) =
+ B (L x (f defs `fmap` ty)) (f (Set.delete x defs) t) %% a
f defs (B (x ::: ty) t a) =
B (x ::: f defs ty) (f (Set.delete x defs) t) %% a
f defs t = descend (f defs) (t :: Pa Expr)
@@ -87,6 +87,7 @@ compileAST mod src@(decls, rules) = do
{-# SCC "check/uniqueness" #-} checkUniqueness src
{-# SCC "check/scopes" #-} checkScopes extdecls src
{-# SCC "check/ordering" #-} Rule.checkOrdering rules
+ {-# SCC "check/arity" #-} Rule.checkArity rules
say Verbose $ text "Checking well formation of rule heads ..."
{-# SCC "check/heads" #-} mapM_ Rule.checkHead rules
say Verbose $ text "Compiling" <+> text (show mod) <+> text "..."
View
@@ -95,9 +95,9 @@ ident = qid . B.pack <$> identifier
-- > | eof
toplevel =
whiteSpace *>
- ( (rule *> toplevel) -- Rules are accumulated by side-effect.
- <|> ((:) <$> declaration <*> toplevel)
- <|> (eof *> return []))
+ choice [ rule *> toplevel -- Rules are accumulated by side effect.
+ , (:) <$> declaration <*> toplevel
+ , eof *> return [] ]
-- | Binding construct.
--
@@ -111,34 +111,27 @@ binding = ((:::) <$> ident <* reservedOp ":" <*> term)
declaration = (binding <* dot)
<?> "declaration"
--- | Left hand side of an abstraction or a product.
+-- | Left hand side of a product or a lambda.
--
--- > domain ::= id ":" applicative
--- > | applicative
-domain = ( ((:::) <$> try (ident <* reservedOp ":") <*> applicative)
- <|> ((qid "hole" .$ "parser" :::) <$> applicative))
- <?> "domain"
+-- > domain ::= [id ":"] applicative "->"
+-- > | id [":" applicative] "=>"
+domain = try (lambda <* reservedOp "=>") <|> try (pi <* reservedOp "->")
+ where lambda = L <$> ident <*> optionMaybe (reservedOp ":" *> applicative) <?> "lambda"
+ pi = (:::) <$> (try (ident <* reservedOp ":") <|> return (qid "hole" .$ "parser"))
+ <*> applicative <?> "pi"
-- |
-- > sort ::= "Type"
sort = Type <$ reserved "Type"
-- | Terms and types.
--
--- We first try to parse as the domain of a lambda or pi. If we
--- later find out there was no arrow after the domain, then we take
--- the domain to be an expression, and return that.
+-- We first try to parse the term as a pi or lambda binding. If it fails,
+-- we parse the rest as an applicative.
--
--- > term ::= domain "->" term
--- > | domain "=>" term
+-- > term ::= domain term
-- > | applicative
-term = do
- d@(x ::: ty) <- domain
- choice [ pi d <?> "pi"
- , lambda d <?> "lambda"
- , return ty ]
- where pi d = B d <$ reservedOp "->" <*> term <%%> nann
- lambda (x ::: _) = B (L x) <$ reservedOp "=>" <*> term <%%> nann
+term = (B <$> domain <*> term <%%> nann) <|> applicative
-- | Constituents of an applicative form.
--
View
@@ -47,10 +47,10 @@ step "," (Binding x : Env y : xs) = Env (x:y) : xs
step "[]" xs = Env [] : xs
-- expressions
-step "=>" (Binding (x ::: _) : Expr t : xs) = Expr (B (L x) t %% nann) : xs
+step "=>" (Binding (x ::: ty) : Expr t : xs) = Expr (B (L x (Just ty)) t %% nann) : xs
step "->" (Binding (x ::: ty) : Expr t : xs) = Expr (B (x ::: ty) t %% nann) : xs
-step "@" (Expr t1 : Expr t2 : xs) = Expr (A t1 t2 %% nann) : xs
-step "Type" xs = Expr Type : xs
+step "@" (Expr t1 : Expr t2 : xs) = Expr (A t1 t2 %% nann) : xs
+step "Type" xs = Expr Type : xs
step v xs = case reverse (B.split '.' v) of
var : quals -> let mod = hierarchy (reverse quals)
in Expr (V (qualify mod (qid var)) %% nann) : xs
Oops, something went wrong.

0 comments on commit cd91c35

Please sign in to comment.