module Language.Clafer.IG.Sugarer (sugarClaferModel) where
import Language.Clafer.IG.ClaferModel
import qualified Language.Clafer.Intermediate.Analysis as Analysis
import Data.Maybe (fromJust)
import Data.List as List hiding (map)
import Data.Map as Map hiding (map, foldr, foldl)
import Prelude hiding (id)
data Census = Census
(Map Id (Int, String))
(Map String Int)
deriving Show
poll :: Id -> Census -> Census
poll id (Census sample' counts') =
Census sample'' counts''
where
fullName = i_name id
name = makeSimpleName fullName
counts'' = insertWith (+) name 1 counts'
ordinal' = findWithDefault (error $ "Did not find " ++ name ++ " in counts.") name counts''
sample'' = insertWith (error $ "Polled " ++ fullName ++ " twice in the census.") id (ordinal', name) sample'
makeSimpleName :: String -> String
makeSimpleName name' = case dropWhile (/='_') name' of
"" -> error "Unexpected Clafer name " ++ name'
x -> tail x
claferModelCensus :: ClaferModel -> Census
claferModelCensus (ClaferModel topLevelClafers) =
clafersCensus (Census Map.empty Map.empty) topLevelClafers
where
clafersCensus = foldl claferCensus
claferCensus census Clafer{c_id=id, c_children=children} = poll id (clafersCensus census children)
sugarClaferModel:: Bool -> Bool -> Maybe Analysis.Info -> ClaferModel -> (Map Int String) -> ClaferModel
sugarClaferModel useUids addTypes info model@(ClaferModel topLevelClafers) sMap =
ClaferModel $ map sugarClafer topLevelClafers
where
sugarClafer (Clafer id value children) =
Clafer (sugarId useUids addTypes True id) (sugarValue (Clafer id value children)) (map sugarClafer children)
sugarValue (Clafer _ (Just (AliasValue alias)) _) = Just $ AliasValue $ sugarId useUids addTypes False alias
sugarValue (Clafer _ Nothing _) = Nothing
sugarValue c = if (cType c) == "string" then (Just ((StringValue) (getString c))) else (c_value c)
cType (Clafer id _ _) = cTypeSolve $ (Analysis.super (Analysis.runAnalysis (Analysis.claferWithUid (i_name id)) (fromJust info)))
cTypeSolve Nothing = ""
cTypeSolve (Just "string") = "string"
cTypeSolve (Just "integer") = "integer"
cTypeSolve (Just "int") = "integer"
cTypeSolve (Just "real") = "real"
cTypeSolve (Just x) = cType (Clafer (Id x 0) Nothing [])
getString c = case (Map.lookup strNumber sMap) of
Nothing -> "\"<text " ++ show strNumber ++ ">\""
Just s -> s
where strNumber = v_value $ fromJust $ c_value c
Census sample' counts' = claferModelCensus model
sugarId :: Bool -> Bool -> Bool -> Id -> Id
sugarId useUids' addTypes' addRefDecl id =
Id (finalName ++ ordinalDisplay ++ (refDecl addTypes' addRefDecl info)) 0
where
fullName = i_name id
ordinalDisplay = if (useUids || count > 1)
then "$" ++ show ordinal
else ""
refDecl :: Bool -> Bool -> Maybe Analysis.Info -> String
refDecl True True (Just info') = retrieveSuper info' $ i_name id
refDecl _ _ _ = ""
(ordinal, simpleName) = findWithDefault (error $ "Sample lookup " ++ show id ++ " failed.") id sample'
count = findWithDefault (error $ "Count lookup " ++ simpleName ++ " failed.") simpleName counts'
finalName = if useUids' then fullName else simpleName
retrieveSuper :: Analysis.Info -> String -> String
retrieveSuper info uid =
(if (Analysis.isBase sclafer)
then ""
else sugarSuper (Analysis.super sclafer))
++ sugarReference (Analysis.reference sclafer)
where
sclafer = Analysis.runAnalysis (Analysis.claferWithUid uid) info
sugarSuper :: Maybe String -> String
sugarSuper (Just s) = " : " ++ s
sugarSuper Nothing = ""
sugarReference :: Maybe String -> String
sugarReference (Just s) = " -> " ++ s
sugarReference Nothing = ""