module ZM.Transform (
MapTypeTree,
typeTree,
solvedADT,
stringADT,
typeDefinition,
adtDefinition,
innerReferences,
references,
getADTRef
) where
import Control.Monad.Trans.State
import Data.Foldable (toList)
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Data.Model.Util (transitiveClosure)
import ZM.Types
import ZM.Util
type MapTypeTree = M.Map (Type AbsRef) (ConTree Identifier AbsRef)
typeTree :: AbsTypeModel -> MapTypeTree
typeTree tm = execEnv (addType (typeEnv tm) (typeName tm))
where
addType absEnv t = do
mct <- M.lookup t <$> get
case mct of
Nothing ->
case declCons $ solvedADT absEnv t of
Just ct -> do
modify (M.insert t ct)
mapM_ (addType absEnv) (conTreeTypeList ct)
Nothing -> return ()
Just _ -> return ()
typeDefinition :: AbsEnv -> AbsType -> Either String [AbsADT]
typeDefinition env t = mapSolve env . nub . concat <$> (mapM (absRecDeps env) . references $ t)
adtDefinition :: AbsEnv -> AbsRef -> Either String [AbsADT]
adtDefinition env t = mapSolve env <$> absRecDeps env t
innerReferences :: AbsADT -> [AbsRef]
innerReferences = nub . mapMaybe getADTRef . nub . toList
references :: AbsType -> [AbsRef]
references = nub . toList
absRecDeps :: AbsEnv -> AbsRef -> Either String [AbsRef]
absRecDeps env ref = either (Left . unlines) Right $ transitiveClosure getADTRef env ref
getADTRef :: ADTRef a -> Maybe a
getADTRef (Ext r) = Just r
getADTRef _ = Nothing
mapSolve :: (Ord k, Show k) => M.Map k b -> [k] -> [b]
mapSolve env = map (`solve` env)
stringADT :: AbsEnv -> AbsADT -> ADT Identifier Identifier (TypeRef Identifier)
stringADT env adt =
let name = declName adt
in ADT name (declNumParameters adt) ((solveS name <$>) <$> declCons adt)
where solveS _ (Var n) = TypVar n
solveS _ (Ext k) = TypRef . declName . solve k $ env
solveS name Rec = TypRef name
solvedADT :: (Ord ref, Show ref) => M.Map ref (ADT name consName (ADTRef ref)) -> Type ref -> ADT name consName ref
solvedADT env at =
let
TypeN t ts = typeN at
as = map typeA ts
adt = solve t env
name = declName adt
in ADT name 0 (conTreeTypeMap (saturate t as) <$> declCons adt)
saturate :: ref -> [Type ref] -> Type (ADTRef ref) -> Type ref
saturate ref vs (TypeApp a b) = TypeApp (saturate ref vs a) (saturate ref vs b)
saturate _ vs (TypeCon (Var n)) = vs !! fromIntegral n
saturate _ _ (TypeCon (Ext r)) = TypeCon r
saturate selfRef _ (TypeCon Rec) = TypeCon selfRef