ChristmasTree 0.1.2 → 0.1.3
raw patch · 6 files changed
+24/−17 lines, 6 filesdep ~TTTASdep ~basedep ~uulib
Dependency ranges changed: TTTAS, base, uulib
Files
- ChristmasTree.cabal +5/−5
- src/Text/GRead/Derive.hs +1/−1
- src/Text/GRead/Derive/BindingGroup.hs +4/−2
- src/Text/GRead/Transformations/LeftCorner.hs +2/−1
- src/Text/GRead/Transformations/LeftFact.hs +2/−1
- src/Text/GShow.hs +10/−7
ChristmasTree.cabal view
@@ -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 <mviera@fing.edu.uy>@@ -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,
src/Text/GRead/Derive.hs view
@@ -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)
src/Text/GRead/Derive/BindingGroup.hs view
@@ -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]
src/Text/GRead/Transformations/LeftCorner.hs view
@@ -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
src/Text/GRead/Transformations/LeftFact.hs view
@@ -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 ) ) )
src/Text/GShow.hs view
@@ -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