module Data.Generics.Alloy.GenInstances
(writeInstances, writeInstancesTo,
justPure, allInstances, instanceImports, instanceImportsMapSet, instanceImportsVector,
GenInstance, genInstance, genMapInstance, genSetInstance, genInstances, languageExtras,
genVectorInstance,
GenOverlappedOption(..), GenClassOption(GenOneClass), GenInstanceConfig(..)) where
import Control.Monad.State
import Data.Char
import Data.Generics
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Ord
import Data.Set (Set)
import Data.Vector (Vector)
import qualified Data.Set as Set
import qualified Data.Typeable as Ty
import qualified Data.Vector as Vector
#if __GLASGOW_HASKELL__ < 702
type TypeRepKey = Int
#endif
data GenOverlappedOption = GenWithOverlapped | GenWithoutOverlapped
deriving (Eq, Read, Show)
data GenClassOption
= GenClassPerType
| GenOneClass
| GenSlowDelegate
deriving (Eq, Read, Show)
data GenInstanceConfig = GenInstanceConfig
{ genOverlapped :: GenOverlappedOption
, genClass :: GenClassOption
, genPure :: Bool
, genEffect :: Bool
, genRoute :: Bool
} deriving (Eq, Read, Show)
justPure :: GenOverlappedOption -> GenInstanceConfig
justPure ov = GenInstanceConfig ov GenOneClass True False False
allInstances :: GenOverlappedOption -> GenInstanceConfig
allInstances ov = GenInstanceConfig ov GenOneClass True True True
mungeName :: String -> String
mungeName = concatMap munge
where
munge :: Char -> String
munge x
| isAlphaNum x = [x]
| otherwise = "__" ++ show (ord x)
newtype GenInstance = GenInstance (TypeMapM ())
genInstance :: Data t => t -> GenInstance
genInstance = GenInstance . findTypesIn (const Nothing)
data Witness
= Plain { witness :: DataBox }
| Detailed { witness :: DataBox
, _directlyContains :: [DataBox]
, _processChildrenMod :: ClassType -> (FuncType -> String, FuncType -> String) -> [String]
}
instance Eq Witness where
(==) wx wy = case (witness wx, witness wy) of
(DataBox x, DataBox y) -> typeOf x == typeOf y
funcPlain :: FuncType -> String
funcPlain Func = ""
funcPlain FuncM = "return"
funcPlain FuncA = "pure"
funcPlain FuncMRoute = "return"
funcPlain FuncARoute = "pure"
funcAp :: FuncType -> String
funcAp Func = " "
funcAp FuncM = "`ap`"
funcAp FuncA = "<*>"
funcAp FuncMRoute = "`ap`"
funcAp FuncARoute = "<*>"
funcTraverse :: FuncType -> String
funcTraverse Func = "fmap"
funcTraverse FuncM = "T.mapM"
funcTraverse FuncA = "T.traverse"
funcTraverse FuncMRoute = "T.mapM"
funcTraverse FuncARoute = "T.traverse"
funcsForClass :: ClassType -> [FuncType]
funcsForClass ct = case ct of
ClassAlloy -> [Func]
ClassAlloyA -> [FuncA, FuncM]
ClassAlloyARoute -> [FuncARoute, FuncMRoute]
genMapInstance :: forall k v. (Ord k, Data k, Data v) => k -> v -> GenInstance
genMapInstance k v
= GenInstance $ do
findTypesIn (const Nothing) (k, v)
tk <- liftIO $ typeKey m
modify (Map.insert tk (toQualName m,
Detailed (DataBox m) [DataBox (k, v), DataBox k, DataBox v]
(\cl (funcSameType, funcNewType) -> concat [
case cl of
ClassAlloyARoute ->
[funcSameType b ++ " _ ops (v, r) = let mns = zip (Map.toList v) (map ((r @->) . routeDataMap) [0..]) in"
," " ++ funcPlain b ++ " Map.fromList " ++ funcAp b
++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b ++ " ops BaseOpARoute) mns)"
]
_ -> let terminator = case cl of
ClassAlloyA -> "BaseOpA"
ClassAlloy -> "BaseOp" in
[funcSameType b ++ " _ ops v = " ++ funcPlain b ++ " Map.fromList "
++ funcAp b ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b
++ " ops " ++ terminator ++ ") (Map.toList v))"
]
| b <- funcsForClass cl])
))
where
m :: Map k v
m = undefined
genSetInstance :: forall a. (Ord a, Data a) => a -> GenInstance
genSetInstance x
= GenInstance $ do
findTypesIn (const Nothing) x
tk <- liftIO $ typeKey s
modify (Map.insert tk (toQualName s,
Detailed (DataBox s) [DataBox x]
(\cl (funcSameType, funcNewType) -> concat [
case cl of
ClassAlloyARoute ->
[funcSameType b ++ " _ ops (v, r) = let sns = zip (Set.toList v) (map ((r @->) . routeDataSet) [0..]) in"
," " ++ funcPlain b ++ " Set.fromList " ++ funcAp b
++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b ++ " ops BaseOpARoute) sns)"
]
_ -> let terminator = case cl of
ClassAlloyA -> "BaseOpA"
ClassAlloy -> "BaseOp" in
[funcSameType b ++ " _ ops v = " ++ funcPlain b ++ " Set.fromList "
++ funcAp b ++ " (" ++ funcTraverse b ++ " (" ++ funcNewType b
++ " ops " ++ terminator ++ ") (Set.toList v))"]
| b <- funcsForClass cl])
))
where
s :: Set a
s = undefined
genVectorInstance :: forall v. (Data v) => v -> GenInstance
genVectorInstance v = GenInstance $ do
findTypesIn (const Nothing) v
tk <- liftIO $ typeKey m
modify $ Map.insert tk $ (,) (toQualName m)
$ Detailed (DataBox m) [DataBox v]
$ \ cl (funcSameType, funcNewType) -> concat
[ case cl of
ClassAlloyARoute -> map concat
[ [ funcSameType b
, " _ ops (v, r) = let mns = zip (Vector.toList v) (map ((r @->) . routeDataMap) [0..]) in"
]
, [ " "
, funcPlain b
, " Vector.fromList "
, funcAp b
, " ("
, funcTraverse b
, " ("
, funcNewType b
, " ops BaseOpARoute) mns)"
]
]
_ -> ((:[]) . concat)
[ funcSameType b
, " _ ops v = "
, funcPlain b
, " Vector.fromList "
, funcAp b
, " ("
, funcTraverse b
, " ("
, funcNewType b
, " ops "
, terminator
, ") (Vector.toList v))"
]
where
terminator = case cl of
ClassAlloyA -> "BaseOpA"
ClassAlloy -> "BaseOp"
| b <- funcsForClass cl
]
where
m :: Vector v
m = undefined
data ClassType = ClassAlloy | ClassAlloyA | ClassAlloyARoute deriving (Eq)
instance Show ClassType where
show ClassAlloy = "Alloy"
show ClassAlloyA = "AlloyA"
show ClassAlloyARoute = "AlloyARoute"
data FuncType = Func | FuncA | FuncM | FuncMRoute | FuncARoute deriving (Eq)
instance Show FuncType where
show Func = "transform"
show FuncA = "transformA"
show FuncM = "transformM"
show FuncARoute = "transformARoute"
show FuncMRoute = "transformMRoute"
instancesFrom :: forall t. Data t => GenOverlappedOption -> GenClassOption ->
ClassType -> [Witness] -> t -> IO [String]
instancesFrom genOverlapped genClass genClassType boxes w
= do (specialProcessChildren, containedTypes) <-
case find (== Plain (DataBox w)) boxes of
Just (Detailed _ containedTypes doChildren) ->
do eachContained <- sequence [findTypesIn' useBoxes c | DataBox c <- containedTypes]
return (Just (containedTypes, doChildren), foldl Map.union Map.empty eachContained)
_ -> do ts <- findTypesIn' useBoxes w
return (Nothing, ts)
containedKeys <- liftM Set.fromList
(sequence [typeKey c | DataBox c <- map witness $ justBoxes containedTypes])
wKey <- typeKey w
otherInsts <- sequence [do ck <- typeKey c
return (otherInst wKey containedKeys c ck)
| DataBox c <- map witness boxes]
return $ baseInst specialProcessChildren ++ concat otherInsts
where
useBoxes k = do b <- lookup k (zip (map witness boxes) boxes)
case b of
Plain {} -> Nothing
Detailed _ contains _ -> Just contains
(wName, wMod) = toQualNameMod w
wMunged = mungeName wName
wDType = dataTypeOf w
wCtrs = if isAlgType wDType then dataTypeConstrs wDType else []
ctrArgs ctr
= gmapQ DataBox (fromConstr ctr :: t)
ctrArgTypes types
= [toQualName w | DataBox w <- types]
genInst :: [String] -> String -> String -> [String] -> [String]
genInst context ops0 ops1 body
= ["instance (" ++ concat (intersperse ", " context) ++ ") =>"
," " ++ contextSameType ops0 ops1 ++ " where"
] ++ map (" " ++) body
contextSameType :: String -> String -> String
contextSameType ops0 ops1 = show genClassType ++ case genClass of
GenOneClass -> " (" ++ wName ++ ") " ++ ops0 ++ " " ++ ops1
GenClassPerType -> wMunged ++" " ++ ops0 ++ " " ++ ops1
GenSlowDelegate -> "' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ wName ++ ")"
contextNewType :: String -> String -> String -> String
contextNewType cName ops0 ops1 = show genClassType ++ case genClass of
GenOneClass -> " (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1
GenClassPerType -> " (" ++ cName ++ ") " ++ ops0 ++ " " ++ ops1
GenSlowDelegate -> "' " ++ ops0 ++ " " ++ ops1 ++ " (" ++ cName ++ ")"
funcSameType :: FuncType -> String
funcSameType func = case genClass of
GenClassPerType -> base ++ wMunged
GenOneClass -> base
GenSlowDelegate -> base ++ "'"
where
base = show func
funcNewType :: FuncType -> String
funcNewType func = case genClass of
GenClassPerType -> base
GenOneClass -> base
GenSlowDelegate -> base ++ "'"
where
base = show func
terminator :: String
terminator = case genClassType of
ClassAlloy -> "BaseOp"
ClassAlloyA -> "BaseOpA"
ClassAlloyARoute -> "BaseOpARoute"
cons :: String
cons = case genClassType of
ClassAlloy -> ":-"
ClassAlloyA -> ":-*"
ClassAlloyARoute -> ":-@"
funcs :: [FuncType]
funcs = funcsForClass genClassType
justData :: String
justData = case genClassType of
ClassAlloyARoute -> "(v, _)"
_ -> "v"
hasRoute = genClassType == ClassAlloyARoute
baseInst :: Maybe ([DataBox], ClassType -> (FuncType -> String, FuncType -> String) -> [String]) -> [String]
baseInst mdoChildren
= concat
[genInst context terminator ("(f " ++ cons ++ " ops)") $
maybe
(concat
[if isAlgType wDType
then (concatMap (constrCase b) wCtrs)
else [funcSameType b ++ " _ _ " ++ justData ++ " = " ++ funcPlain b ++ " v"]
| b <- funcs])
(\(_,f) -> f genClassType (funcSameType, funcNewType)) mdoChildren
,genInst [] terminator terminator
[funcSameType b ++ " _ _ " ++ justData ++ " = " ++ funcPlain b ++ " v" | b <- funcs]
,if genOverlapped == GenWithoutOverlapped then [] else
genInst
[ contextSameType "r" "ops" ]
("(a " ++ cons ++ " r)") "ops"
[funcSameType b ++ " (_ " ++ cons ++ " rest) ops vr = " ++ funcSameType b ++ " rest ops vr"
| b <- funcs]
,if genClass == GenClassPerType
then error "GenClassPerType currently unsupported"
else []
]
where
context :: [String]
context
= [ contextNewType argType ("(f " ++ cons ++ " ops)") terminator
| argType <- nub $ sort $ concatMap ctrArgTypes $
maybe (map ctrArgs wCtrs) ((:[]) . fst) mdoChildren]
constrCase :: FuncType -> Constr -> [String]
constrCase b ctr
= [ funcSameType b ++ " _ " ++ (if argNums == [] then "_" else "ops") ++
" (" ++ ctrInput ++ (if hasRoute then " , " ++ (if argNums == [] then "_" else "rt") else "") ++ ")"
, " = " ++ funcPlain b ++ " " ++ ctrName
] ++
[ " " ++ funcAp b ++ " (" ++ funcNewType b ++ " ops " ++ terminator ++ " (a" ++ show i
++ (if hasRoute then ", rt @-> makeRoute [" ++ show i ++ "] "
++ "(\\f (" ++ ctrMod ++ ") -> f b" ++ show i
++ " >>= (\\b" ++ show i ++ " -> return (" ++ ctrMod ++ ")))"
else "") ++ "))"
| i <- argNums]
where
argNums = [0 .. ((length $ ctrArgs ctr) 1)]
ctrS = show ctr
ctrName = wMod ++ ctrS
makeCtr vs = ctrName ++ concatMap (" " ++) vs
ctrInput = makeCtr ["a" ++ show i | i <- argNums]
ctrMod = makeCtr ["b" ++ show i | i <- argNums]
otherInst :: Data s => TypeRepKey -> Set.Set TypeRepKey -> s -> TypeRepKey -> [String]
otherInst wKey containedKeys c cKey
= if not shouldGen then [] else
genInst context
("((" ++ cName ++ ") " ++ cons ++ " r)")
"ops"
impl
where
cName = toQualName c
(shouldGen, context, impl)
| wKey == cKey
= (True
,[]
,[funcSameType b ++ " (f " ++ cons ++ " _) _ vr = f vr" | b <- funcs])
| cKey `Set.member` containedKeys
= (True
,[contextSameType "r" ("((" ++ cName ++ ") " ++ cons ++ " ops)")]
,[funcSameType b ++ " (f " ++ cons ++ " rest) ops vr = " ++ funcSameType b ++ " rest (f " ++ cons ++ " ops) vr"
| b <- funcs])
| genOverlapped == GenWithoutOverlapped
= (True
,[contextSameType "r" "ops"]
,[funcSameType b ++ " (_ " ++ cons ++ " rest) ops vr = " ++ funcSameType b ++ " rest ops vr"
| b <- funcs])
| otherwise = (False,[],[])
instanceImports :: [String]
instanceImports = map ("import " ++) ["Control.Applicative", "Control.Monad", "Data.Generics.Alloy", "qualified GHC.Types"]
instanceImportsMapSet :: [String]
instanceImportsMapSet = instanceImports ++
map ("import " ++) ["Data.Map(Map)", "qualified Data.Map as Map"
,"Data.Set(Set)", "qualified Data.Set as Set"
,"qualified Data.Traversable as T"
]
instanceImportsVector :: [String]
instanceImportsVector = instanceImports ++ map ("import " ++)
[ "Data.Vector (Vector)"
, "qualified Data.Vector as Vector"
, "qualified Data.Traversable as T"
]
genInstances :: GenInstanceConfig -> [GenInstance] -> IO [String]
genInstances opts insts
= do typeMap <- flip execStateT Map.empty (sequence [g | GenInstance g <- insts])
let inst = [instancesFrom
(genOverlapped opts)
(genClass opts)
classType
(justBoxes typeMap)
w
| DataBox w <- map witness $ justBoxes typeMap,
classType <- classTypes]
inst' <- sequence inst
return $ concat inst'
where
classTypes = concat
[ [ClassAlloy | genPure opts]
, [ClassAlloyA | genEffect opts]
, [ClassAlloyARoute | genRoute opts]
]
languageExtras :: GenOverlappedOption -> String
languageExtras opt = "{-# LANGUAGE TypeOperators, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances"
++ if opt == GenWithOverlapped
then ",OverlappingInstances #-}"
else "#-}"
writeInstances :: GenInstanceConfig -> [GenInstance] -> [String] -> IO ()
writeInstances opts inst header
= do instLines <- genInstances opts inst
putStr (unlines (languageExtras (genOverlapped opts) : (header ++ instLines)))
writeInstancesTo :: GenInstanceConfig -> [GenInstance] -> [String]
-> FilePath -> IO ()
writeInstancesTo opts inst header fileName
= do instLines <- genInstances opts inst
writeFile fileName (unlines (languageExtras (genOverlapped opts) : (header ++ instLines)))
data DataBox = forall t. Data t => DataBox t
instance Eq DataBox where
(==) (DataBox x) (DataBox y) = typeOf x == typeOf y
type TypeMap = Map TypeRepKey (String, Witness)
type TypeMapM = StateT TypeMap IO
typeKey :: Typeable t => t -> IO TypeRepKey
typeKey x = typeRepKey $ typeOf x
toQualName :: Typeable t => t -> String
toQualName w = fst (toQualNameMod w)
toQualNameMod :: Typeable t => t -> (String, String)
toQualNameMod w = toQualNameMod' (typeOf w)
toQualNameMod' :: TypeRep -> (String, String)
toQualNameMod' tr = case (show con, args) of
("[]", [arg]) ->
("[" ++ fst (toQualNameMod' arg) ++ "]", "")
("()", []) -> ("()", "")
('(':',':_, args) ->
("(" ++ show con ++ concat (Prelude.map ((' ' :) . fst . toQualNameMod') args) ++ ")"
, "")
_ | qualCon con == "GHC.Integer.Type.Integer" -> ("Prelude.Integer", "")
_ -> ("(" ++ qualCon con ++ concat (Prelude.map ((' ' :) . fst . toQualNameMod') args) ++ ")"
, modPrefix con)
where
(con, args) = splitTyConApp tr
qualCon :: TyCon -> String
qualCon wc = modPrefix wc ++ show wc
modPrefix :: TyCon -> String
modPrefix wc = case Ty.tyConModule wc of
"" -> ""
m -> m ++ "."
findTypesIn' :: Data t => (DataBox -> Maybe [DataBox]) -> t -> IO TypeMap
findTypesIn' f x = execStateT (findTypesIn f x) Map.empty
findTypesIn :: Data t => (DataBox -> Maybe [DataBox]) -> t -> TypeMapM ()
findTypesIn custom start = doType start
where
doType :: Data t => t -> TypeMapM ()
doType x
= do map <- get
key <- liftIO $ typeRepKey rep
when (not $ key `Map.member` map) $
do modify $ Map.insert key (reps, Plain (DataBox x))
case custom $ DataBox x of
Just inside -> sequence_ [doType y | DataBox y <- inside]
Nothing ->
when (isAlgType dtype) $
mapM_ doConstr $ dataTypeConstrs dtype
where
rep = typeOf x
reps = show rep
dtype = dataTypeOf x
doConstr :: Constr -> TypeMapM ()
doConstr ctr
= sequence_ [doType x' | DataBox x' <- args]
where
args = gmapQ DataBox (asTypeOf (fromConstr ctr) x)
justBoxes :: TypeMap -> [Witness]
justBoxes = map snd . sortBy (comparing fst) . Map.elems
--}}}