|
sourcecode:
|
{-# OPTIONS_FRONTEND -Wno-incomplete-patterns #-}
module RW.Build where
import AbstractCurry.Build
import AbstractCurry.Types as ACT
import AbstractCurry.Select
import FlatCurry.Types as FCT
import Data.List
import Data.Function
import Data.Maybe
import Debug.Trace
import qualified Data.Set as Set
--- Generates a list [0,1,2,...] with the same length as the input list
fromIndex0 :: [a] -> [Int]
fromIndex0 = fromIndex 0
--- Generates a list [i,i+1,i+2,...] with the same length as the input list
fromIndex :: Int -> [a] -> [Int]
fromIndex i xs = take (length xs) [i ..]
--- Generates a var name for a given index
varName :: Int -> String
varName j | j < 26 = [['a'..]!!j] -- a,...,z
| otherwise = [['a'..]!!(j `mod` 26)] ++ (show $ j `div` 26) -- b1,...,z1,b2,...,z2,...
--- Appends an element to a list if a given condition is true
appendIf :: Bool -> [a] -> a -> [a]
appendIf True xs x = xs ++ [x]
appendIf False xs _ = xs
--- Removes the first element from a list if the first list's length is 1. Otherwise, the list is returned unchanged.
optimizeSingleConstructor :: [a] -> [b] -> [b]
optimizeSingleConstructor xs ys = case xs of
[_] -> drop 1 ys
_ -> ys
---------------------------- Type Declarations and Expression ------------------------------------
--- Returns the amount of arguments of a given type constructor
consArity :: CConsDecl -> Int
consArity (CCons _ _ tes) = length tes
consArity (CRecord _ _ fds) = length fds
--- Returns the arguments (type expressions) of a given type constructor
consTypeExpressions :: CConsDecl -> [CTypeExpr]
consTypeExpressions (CCons _ _ tes) = tes
consTypeExpressions (CRecord _ _ fds) = map getTE fds
where
getTE (CField _ _ te) = te
--- Returns true if the given type declaration is polymorphic (contains at least one type variable)
isPolymorphic :: CTypeDecl -> Bool
isPolymorphic (CType _ _ tvs _ _) = not $ null tvs
--- Returns true if the given type declaration is monomorphic (contains no type variables)
isMonomorphic :: CTypeDecl -> Bool
isMonomorphic = not . isPolymorphic
--- All type variables occurring in a given type declaration
typeVars :: CTypeDecl -> [CTVarIName]
typeVars (CType _ _ tvs _ _) = tvs
typeVars (CTypeSyn _ _ tvs _) = tvs
typeVars (CNewType _ _ tvs _ _) = tvs
--- Converts a recursive type expression to a sequence of type expressions
---
--- Example:
--- unwrapApply (CTApply (CTApply (Cons "map") (Var "x")) (Var "y")) = [Cons "map", Var "x", Var "y"]
unwrapApply :: CTypeExpr -> [CTypeExpr]
unwrapApply te = case te of
CTApply a b -> unwrapApply a ++ [b]
_ -> [te]
--- All type variables occurring in a given constructor declaration
consVars :: CConsDecl -> [CTVarIName]
consVars (CCons _ _ tes) = [expr2name x | x <- tes, isTypeVar x]
where
expr2name e = case e of
(CTVar n) -> n
_ -> error "consVars: not a type variable"
--- Returns true if the given type expression is a type variable
isTypeVar :: CTypeExpr -> Bool
isTypeVar te = case te of
CTVar _ -> True
_ -> False
--- The type variable used as the placeholder for instance declarations of the ReadWrite class
genericTypeVariable :: CTypeExpr
genericTypeVariable = CTVar genericTypeVariableName
genericTypeVariableName :: CTVarIName
genericTypeVariableName = (0, "a")
--- Generates the rwClass constraint for all type variables.
--- Given a type
--- data T t1 ... tn = ...
--- This function can be used to derive all constraints necessary to generate the instance header
--- instance (ReadWrite t1, ..., ReadWrite tn) => ReadWrite (T t1 ... tn)
classConstraint :: String -> String -> [CTVarIName] -> [CConstraint]
classConstraint className module' = map (\n -> ((module', className), [CTVar n]))
--- May or may not add the input type to the output. For a given call
--- > returnTypeExpr r a b
--- If r is true, then the resulting type expression is
--- fun :: b -> (a, b)
--- Otherwise, the resulting expression is
--- fun :: b -> a
---
--- This is useful when building type expressions for the read function.
returnTypeExpr :: Bool -> CTypeExpr -> CTypeExpr -> CTypeExpr
returnTypeExpr True te format = format ~> (CTApply (CTApply (CTCons ("Prelude", "(,)")) te) format)
returnTypeExpr False _ format = format ~> CTVar (0, "a")
--- Combines all given expressions with a given operator (right-associative)
combineWithR :: FCT.QName -> [CExpr] -> CExpr
combineWithR op = foldr1 (\x y -> applyF op [x,y])
--- Combines all given expressions with a given operator (left-associative)
combineWithL :: FCT.QName -> [CExpr] -> CExpr
combineWithL op = foldl1 (\x y -> applyF op [x,y])
--- Concats all given expressions with the ++ operator
concatExpr :: [CExpr] -> CExpr
concatExpr = combineWithR (pre "++")
--- Combines all given expressions with the . operator
applyExpr :: [CExpr] -> CExpr
applyExpr = combineWithR (pre ".")
--- Builds an expression 'e1 == e2'
equalsExpr :: CExpr -> CExpr -> CExpr
equalsExpr e1 e2 = applyF (pre "==") [e1, e2]
--- 'otherwise', used for guards
otherwiseExpr :: CExpr
otherwiseExpr = CSymbol $ pre "otherwise"
returnExpr :: CExpr -> CStatement
returnExpr e = CSExpr (CApply (CSymbol (pre "return")) e)
--- Converts a type decl
--- data T t1 ... tn = ...
--- to a type expression
--- T1 t1 ... tn
typeDeclToTypeExpr :: CTypeDecl -> CTypeExpr
typeDeclToTypeExpr decl = case decl of
(CType name _ [] _ _) -> CTCons name
(CType name _ tvs _ _) -> let type' = CTCons name : map CTVar tvs
in foldl1 CTApply type'
--- Converts a type decl
--- data T t1 ... tn = ...
--- to a string
--- T
typeDeclToName :: CTypeDecl -> String
typeDeclToName decl = case decl of
(CType (_, name) _ _ _ _) -> name
--- Returns true iff the given type declaration is a type synonym
isTypeSyn :: CTypeDecl -> Bool
isTypeSyn t = case t of
(CTypeSyn _ _ _ _) -> True
_ -> False
--- Simple pretty printer for type expressions
showTypeExpr :: CTypeExpr -> String
showTypeExpr (CTApply a b) = showTypeExpr a ++ " " ++ showTypeExpr b
showTypeExpr (CTCons (_, name)) = name
showTypeExpr (CTVar (_, name)) = name
showTypeExpr (CFuncType a b) = "(" ++ showTypeExpr a ++ " -> " ++ showTypeExpr b ++ ")"
--- Looks up an existing(!) constructor based on its name
theCons :: ACT.QName -> CTypeDecl -> CConsDecl
theCons cn = fromJust . find ((== cn) . consName) . typeCons
-------------------------------------- Patterns ---------------------------------------------------
--- Anonymous pattern "_"
anonPattern :: CPattern
anonPattern = CPVar (0, "_")
--- Constructs a head:rest-pattern from a list of patterns. For n passed patterns, the resulting pattern is
--- p1:p2:...:pn
--- If the list is empty, the resulting pattern is
--- []
listRestPattern :: [CPattern] -> CPattern
listRestPattern xs = case xs of
[] -> pNil
_ -> foldr1 (\x y -> CPComb (pre ":") [x,y]) xs
--- Pattern-matches the first occurrence of every type variable in a given type expression.
---
--- For a specific constructor of a type definition
--- data T t1 ... tn = ... | C e1 ... em | ...
--- this function generates a pattern
--- C p1 ... pm
--- where pi (1 <= i <= m) is...
--- - a variable ei' if ei the first occurence of a polymorphic type variable t1 ... tn in the constructor
--- - a wildcard _ otherwise
---
--- Example:
--- data T a = C a String a [a]
--- consToPolyPattern C -> C a' _ _ _
consToPolyPattern :: CConsDecl -> CPattern
consToPolyPattern (CCons name _ tes) = CPComb name pats
where
pats = map convert tes
-- Converts a type expression to a pattern such that only type variables are pattern-matched (bound to a variable)
convert te = case te of
CTVar (i, n) -> CPVar (i, n ++ "'")
_ -> anonPattern
-- Replaces all recurrences of type variables in a list of type expressions with wildcards
anonDuplicates (x:xs) | x == anonPattern = x : anonDuplicates xs
| otherwise = x : anonDuplicates (substitute x anonPattern xs)
anonDuplicates [] = []
-- Replaces all occurrences of a type variable pattern with a wildcard pattern
substitute v1 v2 = map (\x -> if x == v1 then v2 else x)
--- Generates a useless rule.
undefinedConstructorRule :: CConsDecl -> CRule
undefinedConstructorRule cons = case cons of
(CCons name _ tes) -> CRule [CPComb name (map (\i -> CPVar (i, varName i)) (fromIndex0 tes))] (CSimpleRhs (CSymbol ("Huh?", "undefined")) [])
_ -> CRule [] (CSimpleRhs (CSymbol ("Huh?", "fail")) [])
-------------------------------------- CurryProg --------------------------------------------------
--- Returns the instance declarations of a curry program
instances :: ACT.CurryProg -> [ACT.CInstanceDecl]
instances (CurryProg _ _ _ _ is _ _ _) = is
--- Returns the name of an instance declaration
instanceName :: ACT.CInstanceDecl -> ACT.QName
instanceName (CInstance name _ _ _) = name
--- Converts a flatcurry program to an abstractcurry program.
--- Extracts only the name, imports and type definitions.
---
--- Converts FCY type synonyms to ACT data declarations.
---
--- Naming scheme for type variables of polymorphic type definitions:
--- data T a ... z a1 ... z1 ... = ...
flatProgToAbstract :: FCT.Prog -> ACT.CurryProg
flatProgToAbstract (FCT.Prog name is ts _ _) = ACT.CurryProg name is Nothing [] [] (filter (not . isPrefixOf "_Dict#" . typeDeclToName) (map flatTypeDeclToAbstract ts)) [] []
where
flatTypeDeclToAbstract t = case t of
(FCT.Type qn vis tvar cds) -> ACT.CType qn (flatVisiblityToAbstract vis) (map flatTypeVarToAbstract tvar) (map flatConstrDeclToAbstract cds) []
(FCT.TypeNew qn vis tvar c) -> ACT.CType qn (flatVisiblityToAbstract vis) (map flatTypeVarToAbstract tvar) [flatNewConsToAbstractCons c] []
flatVisiblityToAbstract v = case v of
FCT.Public -> ACT.Public
FCT.Private -> ACT.Private
flatTypeVarToAbstract (index, _) = (index, varName index)
flatConstrDeclToAbstract (FCT.Cons qn _ vis tes) = ACT.CCons qn (flatVisiblityToAbstract vis) (map flatTypeExprToAbstract tes)
flatNewConsToAbstractCons (FCT.NewCons qn vis te) = ACT.CCons qn (flatVisiblityToAbstract vis) [flatTypeExprToAbstract te]
flatTypeExprToAbstract fte = case fte of
FCT.TVar index -> ACT.CTVar (index, varName index)
FCT.FuncType t1 t2 -> ACT.CFuncType (flatTypeExprToAbstract t1) (flatTypeExprToAbstract t2)
FCT.TCons qn tes -> case tes of
[] -> ACT.CTCons qn
_ -> applyTC qn (map flatTypeExprToAbstract tes)
_ -> error "flatTypeExprToAbstract: forall quantifier not supported yet"
--- auxiliary util functions
--- If just a value is given, the predicate is applied to the value. Otherwise, false is returned.
whenJust :: Maybe a -> (a -> Bool) -> Bool
whenJust (Just x) f = f x
whenJust Nothing _ = False
--- not . any
none :: (a -> Bool) -> [a] -> Bool
none f = not . any f
--- snd of a triple
snd3 :: (a, b, c) -> b
snd3 (_, x, _) = x
|