diff --git a/ChristmasTree.cabal b/ChristmasTree.cabal --- a/ChristmasTree.cabal +++ b/ChristmasTree.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.2.3 build-type: Simple name: ChristmasTree -version: 0.1.2 +version: 0.1.3 license: LGPL license-file: COPYRIGHT maintainer: Marcos Viera @@ -11,11 +11,11 @@ category: Parsing stability: Experimental copyright: Universiteit Utrecht -build-depends: base >= 2 && < 4, haskell98, template-haskell, containers, - fgl>=5.4, TTTAS, uulib +build-depends: base >= 2 && <= 4.1.0.0, haskell98, template-haskell, + containers, fgl>=5.4, TTTAS >= 0.3 , uulib >= 0.9.11 exposed-modules: Text.GRead, Text.GShow, - Text.GRead.Derive, Text.GRead.Grammar -other-modules: Text.GRead.Derive.BindingGroup, + Text.GRead.Derive, Text.GRead.Grammar, + Text.GRead.Derive.BindingGroup, Text.GRead.Transformations.GramTrafo, Text.GRead.Transformations.Group, Text.GRead.Transformations.LeftCorner, diff --git a/src/Text/GRead/Derive.hs b/src/Text/GRead/Derive.hs --- a/src/Text/GRead/Derive.hs +++ b/src/Text/GRead/Derive.hs @@ -106,7 +106,7 @@ nontsInstance = mkNontsInstance strongEdges bindingGroup' (instanceExps instances') topPat = map varP (instanceNames instances') env = appsE $ (lamE topPat nontsInstance) : (linkRefs (length instances')) - [d| grammar = DGrammar Zero $(sigE env (envSignature cs (instanceTypes instances'))) |] + [d| grammar :: DGrammar a; grammar = DGrammar Zero $(sigE env (envSignature cs (instanceTypes instances'))) |] where instanceNames = map (fst . fst) instanceTypes = map (snd . fst) diff --git a/src/Text/GRead/Derive/BindingGroup.hs b/src/Text/GRead/Derive/BindingGroup.hs --- a/src/Text/GRead/Derive/BindingGroup.hs +++ b/src/Text/GRead/Derive/BindingGroup.hs @@ -81,13 +81,13 @@ bgroup <- getBindingGroup name let bgroup' = map show bgroup [|bgroup'|] - +{- showTypeGraph :: Name -> Q Exp showTypeGraph name = do tgraph <- getTypeGraph name let tgraph' = show tgraph [|tgraph'|] - +-} -- | Find cyclic type dependencies (binding groups) getBindingGroup :: Name -> Q BindingGroup getBindingGroup name = do @@ -160,6 +160,7 @@ getCtx ((NormalC _ args) :cs) = (map snd args) ++ (getCtx cs) getCtx ((InfixC argl _ argr) :cs) = (snd argl) : ((snd argr) : (getCtx cs)) getCtx ((RecC _ args) :cs) = (map thd args) ++ (getCtx cs) +getCtx _ = error "Error: the impossible happened in getCtx!" -- Not exhaustive: missing ForallC thd :: (a, b, c) -> c @@ -232,6 +233,7 @@ where unrollApp' :: Type -> [Type] -> [Type] unrollApp' (AppT sub@(AppT _ _) arg) args = unrollApp' sub (arg:args) unrollApp' (AppT top arg) args = top:(arg:args) + unrollApp' _ _ = error "Error: the impossible happened in unrollApp" -- Not exhaustive: missing ArrowT, ContT, ForallT, ListT, ... replaceVars :: [Type] -> VarMap -> [Type] diff --git a/src/Text/GRead/Transformations/LeftCorner.hs b/src/Text/GRead/Transformations/LeftCorner.hs --- a/src/Text/GRead/Transformations/LeftCorner.hs +++ b/src/Text/GRead/Transformations/LeftCorner.hs @@ -51,7 +51,7 @@ rule1 gram (Seq x beta) = proc tenv_s -> do insert gram x -< (tenv_s, mapProd tenv_s beta) - +rule1 _ _ = error "Error: the impossible haṕpened in LeftCorner::rule1" rule2 :: Env Productions env env -> Symbol x env @@ -81,6 +81,7 @@ do insert gram x -< (tenv_s, append (flip (.)) (mapProd tenv_s beta) (Nont a_b)) +rule2b _ _ = error "Error: the impossible haṕpened in LeftCorner::rule2b" insert :: forall env s a x . Env Productions env env diff --git a/src/Text/GRead/Transformations/LeftFact.hs b/src/Text/GRead/Transformations/LeftFact.hs --- a/src/Text/GRead/Transformations/LeftFact.hs +++ b/src/Text/GRead/Transformations/LeftFact.hs @@ -103,12 +103,13 @@ addprod x -< (env2s,r) of Trafo step -> step (MapA_X m) Just r -> TrafoE (MapA_X m) - (\(_,p) t e -> + (\(_,p) t e u -> ( PS [] , t , updateEnv (\(PS ps) -> PS (p:ps)) r e + , u ) ) ) diff --git a/src/Text/GShow.hs b/src/Text/GShow.hs --- a/src/Text/GShow.hs +++ b/src/Text/GShow.hs @@ -2,8 +2,8 @@ module Text.GShow ( GShow(..), deriveShow, app_prec ) where -import Text.GRead -import Language.TTTAS +-- import Text.GRead +-- import Language.TTTAS import Language.Haskell.TH import Language.Haskell.TH.Syntax @@ -14,7 +14,8 @@ gshow :: a -> String gshowsPrec :: Int -> a -> ShowS -app_prec = 10 :: Int +app_prec :: Int +app_prec = 10 data ADInfo = ADInfo [Name] [Con] @@ -26,7 +27,7 @@ ctx = map (AppT (ConT ''GShow)) (nub $ filterVars $ unrollApps $ mkContext cons) typ = AppT (ConT ''GShow) (foldl1' AppT $ (ConT name):targs) - gs <- [d| gshow a = gshowsPrec 0 a "" |] + gs <- [d| gshow :: (GShow a) => a -> String; gshow a = gshowsPrec 0 a "" |] let clcons = map deriveShowCon cons gsps <- funD (mkName "gshowsPrec") clcons return [ InstanceD ctx typ (gsps:gs) ] @@ -37,6 +38,7 @@ mkContext [] = [] mkContext ((NormalC _ args) :cs) = (map snd args) ++ (mkContext cs) mkContext ((InfixC argl _ argr) :cs) = (snd argl) : ((snd argr) : (mkContext cs)) +mkContext _ = error "Error: the impossible happened in mkContext" filterVars :: Cxt -> Cxt filterVars [] = [] @@ -53,7 +55,7 @@ where unrollApp' :: Type -> [Type] -> [Type] unrollApp' (AppT sub@(AppT _ _) arg) args = unrollApp' sub (arg:args) unrollApp' (AppT top arg) args = top:(arg:args) - + unrollApp' _ _ = error "Error: the impossible happened in unrollApp" deriveShowCon :: Con -> Q Clause @@ -76,7 +78,6 @@ conc (s:[]) = [| $(s) |] conc (s:rs) = [| $(s) . $(conc rs)|] - deriveShowCon (InfixC _ name _) = do f <- getPrec name clause [varP (mkName "d"), pat] (bdy f) [] @@ -96,7 +97,9 @@ (litE $ StringL (' ' : nameBase name ++ " "))) str fl fr = appE (appE (varE $ mkName ".") (strl fl)) (fshowsPrec fr (varE r)) - + +deriveShowCon _ = error "Error: the impossible happened in deriveShowCon" + getPrec :: Name -> Q (Int, Int, Int) getPrec name = do (DataConI _ _ _ (Fixity f fd)) <- reify name