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.1 +version: 0.1.2 license: LGPL license-file: COPYRIGHT maintainer: Marcos Viera 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 @@ -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