diff --git a/ChristmasTree.cabal b/ChristmasTree.cabal --- a/ChristmasTree.cabal +++ b/ChristmasTree.cabal @@ -1,18 +1,18 @@ cabal-version: >=1.2.3 build-type: Simple name: ChristmasTree -version: 0.1.4 +version: 0.2 license: LGPL license-file: COPYRIGHT maintainer: Marcos Viera homepage: http://www.cs.uu.nl/wiki/bin/view/Center/TTTAS -description: Alternative approach of 'read' that composes grammars instead of parsers. It reads data in linear time, while the function 'read' has an exponential behavior in some cases of data types with infix operators. -synopsis: Changing Haskell's Read Implementation Such That by Mainpulating Abstract Syntax Trees it Reads Expressions Efficiently +description: ChristmasTree (Changing Haskell's Read Implementation Such That by Mainpulating ASTs it Reads Expressions Efficiently) is an alternative approach of 'read' that composes grammars instead of parsers. It reads data in linear time, while the function 'read' has an exponential behavior in some cases of data types with infix operators. +synopsis: Alternative approach of 'read' that composes grammars instead of parsers. category: Parsing stability: Experimental copyright: Universiteit Utrecht -build-depends: base >= 2 && <= 4.1.0.0, haskell98, template-haskell < 2.4, - containers, fgl>=5.4, TTTAS >= 0.3 , uulib >= 0.9.11 +build-depends: base >= 4 && < 5, haskell98, template-haskell >= 2.4, containers, + fgl>=5.4, TTTAS >= 0.4 , uulib >= 0.9.11 exposed-modules: Text.GRead, Text.GShow, Text.GRead.Derive, Text.GRead.Grammar, Text.GRead.Derive.BindingGroup, diff --git a/examples/Test.hs b/examples/Test.hs --- a/examples/Test.hs +++ b/examples/Test.hs @@ -1,7 +1,7 @@ module Test where import Text.GRead -import Language.TTTAS +import Language.AbstractSyntax.TTTAS infixl 5 :<:, :+: infixr 6 :>:, :*: diff --git a/examples/TestDerive.hs b/examples/TestDerive.hs --- a/examples/TestDerive.hs +++ b/examples/TestDerive.hs @@ -62,7 +62,6 @@ | C16 - $(deriveGrammar ''T1) $(deriveGrammar ''T2) $(deriveGrammar ''T3) @@ -75,7 +74,9 @@ $(deriveGrammar ''T10) $(deriveGrammar ''T11) $(deriveGrammar ''T12) + $(deriveGrammar ''T13) + $(deriveGrammar ''T14) -- $(deriveGrammar ''T15) -- doesn't work -- $(deriveGrammar ''T16) -- doesn't work @@ -125,4 +126,3 @@ res = gread "BT O_nop BT (O_B T10 C9) (O_E T14 C1 C3)" :: GReadResult (BT T1 T10 T11 T12 (T14 T1 T3)) - diff --git a/src/Text/GRead.hs b/src/Text/GRead.hs --- a/src/Text/GRead.hs +++ b/src/Text/GRead.hs @@ -35,7 +35,7 @@ ) where -import Language.TTTAS +import Language.AbstractSyntax.TTTAS import Text.GRead.Grammar import Text.GRead.Transformations.LeftFact import 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 @@ -18,7 +18,7 @@ module Text.GRead.Derive (deriveGrammar, deriveSimpleGrammar) where import Text.GRead.Grammar -import Language.TTTAS +import Language.AbstractSyntax.TTTAS import Text.GRead.Derive.BindingGroup @@ -69,7 +69,7 @@ return [InstanceD (mkContext cs) (mkInstanceType name args) body] mkContext :: [Con] -> Cxt -mkContext = map (AppT (ConT ''Gram)) . uniqueVars . consArgsTypes +mkContext = map (ClassP ''Gram) . map (: []) . uniqueVars . consArgsTypes mkInstanceType :: Name -> [Name] -> Type mkInstanceType name = AppT (ConT ''Gram) . foldl1' AppT . (:) (ConT name) . map VarT @@ -83,7 +83,7 @@ consArgs _ = error "Error, unsupported type." uniqueVars :: [Type] -> [Type] -uniqueVars = nub . filter isVarT . unrollApps +uniqueVars = nub . filter isVarT . unrollApps where unrollApps :: [Type] -> [Type] unrollApps [] = [] @@ -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 a; 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) @@ -155,8 +155,8 @@ then envSignature' else forallT (consVars cs) (return $ mkContext cs) envSignature' where - consVars :: [Con] -> [Name] - consVars = map (\(VarT n) -> n) . uniqueVars . consArgsTypes + consVars :: [Con] -> [TyVarBndr] + consVars = map (\(VarT n) -> (PlainTV n)) . uniqueVars . consArgsTypes envSignature' :: Q Type envSignature' = foldl1' appT [conT ''Env, conT ''DGram, tupleTypes types, tupleTypes types] @@ -213,7 +213,7 @@ refTo = (topType : argsType) ++ concatMap edgeType edges ++ getEdges typeName strongEdges refs = map (\r -> AppT (AppT ref r) env) refTo nontsType = foldr' (\r rs -> AppT (AppT ArrowT r) rs) resultType refs - return $ ForallT (envName:args) [] nontsType + return $ ForallT ((PlainTV envName):(map PlainTV args)) [] nontsType edgeType :: (Name, [[Type]]) -> [Type] edgeType (con, argss) = map (foldl' AppT (ConT con)) argss 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 @@ -140,11 +140,16 @@ info <- reify name case info of TyConI d -> case d of - (DataD _ uname args cs _) -> return $ UserD uname args cs - (NewtypeD _ uname args c _) -> return $ UserD uname args [c] + (DataD _ uname args cs _) -> return $ UserD uname (map tyVarBndr2Name args) cs + (NewtypeD _ uname args c _) -> return $ UserD uname (map tyVarBndr2Name args) [c] _ -> scopeError _ -> scopeError where scopeError = error $ "Can only be used on algebraic datatypes (which " ++ (show name) ++ " isn't)" + + +tyVarBndr2Name :: TyVarBndr -> Name +tyVarBndr2Name (PlainTV n) = n +tyVarBndr2Name (KindedTV n _) = n extendGraphType :: InheritState -> UserType -> Q SynthesizedState extendGraphType state (UserD _ _ cons) = do diff --git a/src/Text/GRead/Grammar.hs b/src/Text/GRead/Grammar.hs --- a/src/Text/GRead/Grammar.hs +++ b/src/Text/GRead/Grammar.hs @@ -31,7 +31,7 @@ matchSym, append ) where -import Language.TTTAS (Env(..), Ref(..), Equal(..), match) +import Language.AbstractSyntax.TTTAS (Env(..), Ref(..), Equal(..), match) -- | -- diff --git a/src/Text/GRead/Transformations/GramTrafo.hs b/src/Text/GRead/Transformations/GramTrafo.hs --- a/src/Text/GRead/Transformations/GramTrafo.hs +++ b/src/Text/GRead/Transformations/GramTrafo.hs @@ -2,7 +2,7 @@ module Text.GRead.Transformations.GramTrafo where -import Language.TTTAS +import Language.AbstractSyntax.TTTAS import Text.GRead.Grammar newtype MapA_X env a env' diff --git a/src/Text/GRead/Transformations/Group.hs b/src/Text/GRead/Transformations/Group.hs --- a/src/Text/GRead/Transformations/Group.hs +++ b/src/Text/GRead/Transformations/Group.hs @@ -2,7 +2,7 @@ module Text.GRead.Transformations.Group where -import Language.TTTAS +import Language.AbstractSyntax.TTTAS import Text.GRead.Grammar import Control.Arrow @@ -73,8 +73,8 @@ gGrammar :: DGrammar a -> GTrafo s t (ListDR a s) gGrammar (DGrammar r gram) = proc _ -> - mdo let env_s = dmap2trans menv_s - menv_s <- gDGrams gram -< env_s + do rec let env_s = dmap2trans menv_s + menv_s <- gDGrams gram -< env_s returnA -< lookupEnv r (unDMapping menv_s) 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 @@ -2,7 +2,7 @@ module Text.GRead.Transformations.LeftCorner (leftcorner) where -import Language.TTTAS +import Language.AbstractSyntax.TTTAS import Text.GRead.Grammar import Text.GRead.Transformations.GramTrafo import Control.Arrow @@ -17,8 +17,8 @@ lctrafo :: Env Productions env env -> Trafo Unit Productions s () (T env s) lctrafo productions = proc _ -> - mdo let tenv_s = map2trans menv_s - menv_s <- (rules1 productions productions) -< tenv_s + do rec let tenv_s = map2trans menv_s + menv_s <- (rules1 productions productions) -< tenv_s returnA -< tenv_s 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 @@ -2,7 +2,7 @@ module Text.GRead.Transformations.LeftFact (leftfactoring) where -import Language.TTTAS +import Language.AbstractSyntax.TTTAS import Text.GRead.Grammar import Text.GRead.Transformations.GramTrafo import Control.Arrow @@ -30,8 +30,8 @@ lftrafo :: Env Productions env env -> Trafo Unit Productions s () (BT env s) lftrafo productions = proc _ -> - mdo let tenv_s = map2trans menv_s - (b,menv_s) <- (rules productions) -< tenv_s + do rec let tenv_s = map2trans menv_s + (b,menv_s) <- (rules productions) -< tenv_s returnA -< BT (b,tenv_s) diff --git a/src/Text/GShow.hs b/src/Text/GShow.hs --- a/src/Text/GShow.hs +++ b/src/Text/GShow.hs @@ -24,23 +24,24 @@ deriveShow name = do (ADInfo args cons) <- getInfo name let targs = map VarT args - ctx = map (AppT (ConT ''GShow)) (nub $ filterVars $ unrollApps $ mkContext cons) + -- ctx = map (AppT (ConT ''GShow)) (nub $ filterVars $ unrollApps $ mkContext cons) + -- typ = AppT (ConT ''GShow) (foldl1' AppT $ (ConT name):targs) + ctx = map (ClassP ''GShow) $ map (: []) (nub $ filterVars $ unrollApps $ mkContext cons) typ = AppT (ConT ''GShow) (foldl1' AppT $ (ConT name):targs) - - gs <- [d| gshow :: (GShow a) => a -> String; 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) ] -mkContext :: [Con] -> Cxt +mkContext :: [Con] -> [Type] 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 :: [Type] -> [Type] filterVars [] = [] filterVars (v@(VarT _):vs) = v : filterVars vs filterVars (_:vs) = filterVars vs @@ -117,9 +118,13 @@ info <- reify name case info of TyConI d -> case d of - (DataD _ _ args cs _) -> return $ ADInfo args cs - (NewtypeD _ _ args c _) -> return $ ADInfo args [c] + (DataD _ _ args cs _) -> return $ ADInfo (map tyVarBndr2Name args) cs + (NewtypeD _ _ args c _) -> return $ ADInfo (map tyVarBndr2Name args) [c] _ -> scopeError _ -> scopeError where scopeError = error $ "Can only be used on algebraic datatypes (which " ++ (show name) ++ " isn't)" + +tyVarBndr2Name :: TyVarBndr -> Name +tyVarBndr2Name (PlainTV n) = n +tyVarBndr2Name (KindedTV n _) = n