ChristmasTree 0.1.1 → 0.1.2
raw patch · 2 files changed
+24/−12 lines, 2 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChristmasTree.cabal +1/−1
- src/Text/GRead/Derive.hs +23/−11
ChristmasTree.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.2.3 build-type: Simple name: ChristmasTree-version: 0.1.1+version: 0.1.2 license: LGPL license-file: COPYRIGHT maintainer: Marcos Viera <mviera@fing.edu.uy>
src/Text/GRead/Derive.hs view
@@ -80,6 +80,7 @@ consArgs :: Con -> [Type] consArgs (NormalC _ args) = map snd args consArgs (InfixC argl _ argr) = [snd argl, snd argr]+ consArgs _ = error "Error, unsupported type." uniqueVars :: [Type] -> [Type] uniqueVars = nub . filter isVarT . unrollApps@@ -114,16 +115,16 @@ -- Only edges that are not in the binding group calculateStrongEdges :: [(Name, [[Type]])] -> (Name, [(Name, [[Type]])]) -> Q (Name, [Type])-calculateStrongEdges needed (typeName, edges) = do+calculateStrongEdges needed (typeName, _) = do (UserD _ _ cs) <- getUserType typeName return $ (typeName, mkNonBGEdges typeName (map fst needed) (bindingGroupEdges typeName needed) cs) where- bindingGroupEdges typeName needed = maybe [] concat $ Prelude.lookup typeName needed+ bindingGroupEdges tName nd = maybe [] concat $ Prelude.lookup tName nd mkNonBGEdges self done before = filter (not . already done before self) . consArgsTypes already :: [Name] -> [Type] -> Name -> Type -> Bool- already done before self (VarT _) = True+ already _ _ _ (VarT _) = True already done before self c@(ConT name) = elem c before || elem name done || name == self@@ -131,6 +132,7 @@ || elem (conName a) done || (conName a) == self where conName = (\(ConT name) -> name) . head . unrollApp+ already _ _ _ _ = error "Error, unsupported type." -- TODO Incomplete: TupleT, ListT, etc... getEdges :: Name -> [(Name, [Type])] -> [Type]@@ -170,7 +172,7 @@ -- Return a list of tuples of the name of an instance and the instance itself createInstances :: [(Name, [[Type]])] -> [(Name, [Type])] -> (Name, [(Name, [[Type]])]) -> Q [((Name, Type), ExpQ)] createInstances needed strongEdges (typeName, edges) = do- (UserD _ args cs) <- getUserType typeName+ (UserD _ args _) <- getUserType typeName let instancesNeeded = maybe [map VarT args] id $ Prelude.lookup typeName needed return $ mkInstances instancesNeeded ++ mkArgInstances instancesNeeded@@ -182,7 +184,7 @@ mkInstances = map (createInstance (typeName, edges) (getEdges typeName strongEdges)) mkArgInstances = map mkConsG . filter isVarT . concat - mkNonBGInstances typeName = map mkConsG . getEdges typeName+ mkNonBGInstances tName = map mkConsG . getEdges tName createInstance :: (Name, [(Name, [[Type]])]) -> [Type] -> [Type] -> ((Name, Type), ExpQ)@@ -197,7 +199,7 @@ instName top (VarT n) = var2TopRef top n instName _ (ConT n) = type2TopRef n instName _ app@(AppT _ _) = app2TopRef $ unrollApp app-+instName _ _ = error "Error, unsupported type." mkNontsType :: [(Name, [Type])] -> (Name, [(Name, [[Type]])]) -> Q Type mkNontsType strongEdges (typeName, edges) = do@@ -227,6 +229,7 @@ where getTypeName (ConT name) = type2Ref name getTypeName a@(AppT _ _) = app2Ref (unrollApp a) + getTypeName _ = error "Error, unsupported type." -- TODO Incomplete: TupleT, ListT, etc... @@ -240,19 +243,21 @@ -- TODO: Extend this for 'AppT' and clean up nameArgs :: Name -> [Type] -> Name-nameArgs baseName [] = baseName+nameArgs baseName [] = baseName nameArgs baseName ((ConT name):types) = nameArgs (mkName $ nameBase baseName ++ "'" ++ nameBase name) types nameArgs baseName ((VarT name):types) = nameArgs (mkName $ nameBase baseName ++ "'" ++ nameBase name) types-+nameArgs _ _ = error "Error, unsupported type." -- TODO: Simplification, not finished, doesn't support AppT at the moment getNeededInstances :: (Name, [[Type]]) -> [(Name, [Type])] getNeededInstances (top, argss) = concatMap (\args -> (top,args): map (\arg -> (typeName arg, [])) args) argss- where typeName (ConT n) = n -- Break with a pattern match failure+ where typeName (ConT n) = n -- Break with a pattern match failure+ typeName _ = error "Error, unsupported type." linkRefs :: Int -> [ExpQ] linkRefs x = linkRefs' (x-1) [[|Zero|]] -- Minus one is for the top type, works always where linkRefs' 0 done = reverse done- linkRefs' x' l@(last:_) = linkRefs' (x' - 1) ((appE [|Suc|] last):l)+ linkRefs' x' l@(lst:_) = linkRefs' (x' - 1) ((appE [|Suc|] lst):l)+ linkRefs' _ _ = error "Impossible Error!" type PrecProd = Map Int [ExpQ] @@ -276,17 +281,21 @@ getTypeRef top p (_,t) = [| dNont ($(varE (refTo top t)), p) |] where refTo top' (VarT n) = var2Ref top' n refTo _ (ConT n) = type2Ref n- refTo top' app@(AppT _ _) = appOrType2Ref top' $ unrollApp app + refTo top' app@(AppT _ _) = appOrType2Ref top' $ unrollApp app+ refTo _ _ = error "Error, unsupported type." appOrType2Ref cur app@((ConT con):_) | cur == con = type2Ref cur -- TODO: Is this always true? | otherwise = app2Ref app+ appOrType2Ref _ _ = error "Error, unsupported type." -- TODO Incomplete? -- TODO: first argument doesn't have to be a con! app2Ref :: [Type] -> Name app2Ref ((ConT con):args) = nameArgs (type2Ref con) args +app2Ref _ = error "Error, unsupported type." app2TopRef :: [Type] -> Name app2TopRef ((ConT con):args) = nameArgs (type2TopRef con) args +app2TopRef _ = error "Error, unsupported type." -- TODO: Nice for readability, but should be cleaned up type2Ref :: Name -> Name@@ -343,8 +352,11 @@ where fLeft InfixL = 0 fLeft InfixR = 1+ fLeft _ = error "Error, unsupported fixity." fRight InfixR = 0 fRight InfixL = 1+ fRight _ = error "Error, unsupported fixity."+ insertCon' :: Int -> ExpQ -> PrecProd -> Q PrecProd insertCon' i e pp = return $ Map.insertWith (flip (++)) i [e] pp