Commit bc87f9d2 authored by Jasper Paul Sikorra's avatar Jasper Paul Sikorra Committed by Jasper Paul Sikorra
Browse files

Add version 0.0.1 of ICurry

parents
Copyright (c) 2017, Bastian Kirchmayr
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the names of the copyright holders nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
ICurry
======
{
"name": "icurry",
"version": "0.0.1",
"author": "Bastian Kirchmayr <bki@informatik.uni-kiel.de>",
"maintainer": "Jasper Paul Sikorra <jsi@informatik.uni-kiel.de>",
"synopsis": "Intermediate language for the translation of Curry to imperative languages",
"category": [ "Metaprogramming" ],
"license": "BSD-3-Clause",
"licenseFile": "LICENSE",
"dependencies": {
}
}
--- Transforms an Annotated FlatCurry program into ICurry
module ICurry.GenICurry where
import FlatCurry.Annotated.Types
import FlatCurry.Annotated.Goodies
( allVarsInRule, annExpr, isCombTypeFuncCall, isCombTypeFuncPartCall
, isTypeSyn, trTypeExpr, updTVars)
import FlatCurry.Types (Pattern(..))
import Rewriting.Term (Term(..))
import Rewriting.Unification (unify)
import FiniteMap
(FM, addListToFM, emptyFM, fmToList, lookupFM, plusFM)
import List (nub, maximum, sortBy)
import Maybe ((>>-), fromJust, fromMaybe)
import SetRBT
(SetRBT, deleteRBT, elemRBT, emptySetRBT, insertRBT, setRBT2list, unionRBT)
import ICurry.Types
import ICurry.ISState
--- Main transformation function
genIProg :: AProg TypeExpr -> IS IProg
genIProg (AProg mod is tys fns _) =
-- generator functions for each data type
mapES genGenFunc dTys >+= \gFuncs ->
-- regular functions
mapES genFuncs fns >+= \fFuncss ->
returnES $ IProg mod is iDatas (gFuncs ++ concat fFuncss)
where
dTys = filter (not . isTypeSyn) tys
iDatas = map buildIData dTys
--- Transforms data types into IData's
buildIData :: TypeDecl -> IData
buildIData (Type (_, name) _ _ conss) = IData dName $ map buildICons conss
where
dName = buildName DataId name
buildIData (TypeSyn _ _ _ _) = error "Cam.GenICurry.buildIData: unreachable"
buildICons :: ConsDecl -> ICons
buildICons (Cons (_, name) arity _ _) = ICons (buildName ConsId name) arity name
--- Builds a generator function for each data type
genGenFunc :: TypeDecl -> IS IFunc
genGenFunc (Type (_, name) _ ps conss) =
-- ids of type variables are reused as variable ids
setGenVars (zip ps ps) >+
unzipMapES genGenCons conss >+= \(exprs, envs) ->
let (dem, _) = combineEnvs envs
arity = length ps
fName = buildName GenId name
f v | v `elemRBT` dem = IParam v
| otherwise = IAnonParam in
-- (IFree exprs) is a disjunction of all constructors
returnES $ IFunc fName arity Private Nothing (IRule (map f ps) [] (IFree exprs))
genGenFunc (TypeSyn _ _ _ _) = error "Cam.GenICurry.genGenFunc: unreachable"
--- Builds an expression that contains a constructor with generator calls as its
--- arguments
genGenCons :: ConsDecl -> VE
genGenCons (Cons (mod, name) _ _ tys) =
unzipMapES (genIGen IGen) tys >+= \(iExprs, envs) ->
returnVE (IComb ConsCall (mod, buildName ConsId name) iExprs) $ combineEnvs envs
--- Splits an Annotated FlatCurry function into several ICurry functions
genFuncs :: AFuncDecl TypeExpr -> IS [IFunc]
genFuncs (AFunc (_, name) arity v ty rule) =
newFunc name nextId >+
checkRule name rule >+
genIRules arity v (typeArgs ty) rule >+
getRules >+= \rs ->
returnES $ map (\(n, v, r) -> IFunc n arity v (Just ty) r) rs
where
nextId = minFreeId (allVarsInRule rule)
--- Adds special main function if necessary
checkRule :: String -> ARule TypeExpr -> IS ()
checkRule name r | name == "*" = case r of
ARule _ [(p1, _),(p2, _)] (ACase _ _ (AVar _ p3) [b1]) | p1 == p3 -> case b1 of
ABranch (ALPattern _ (Intc 6)) (ACase _ _ (AVar _ p4) [b2]) | p2 == p4 -> case b2 of
ABranch (ALPattern _ (Intc 9)) (ALit _ (Intc 42))
-> addRule_ (const "x_main") Private (IRule [] [] (ILit (Intc 42)))
_ -> returnES ()
_ -> returnES ()
_ -> returnES ()
| otherwise = returnES ()
--- Builds IRules from an Annotated FlatCurry rule and adds them to the state
genIRules :: Arity -> Visibility -> [TVarIndex] -> ARule TypeExpr -> IS ()
genIRules arity v _ (AExternal _ str) =
addRule_ (buildName FuncId) v $ IExternal arity str
genIRules _ v tVars (ARule _ ps expr) =
mapES (const newVarId) tVars >+= \genPs ->
-- generator parameter for each type parameter
setGenVars (zip tVars genPs) >+
genIExpr expr >+= \(iExpr, (dem, def)) ->
getTopRuleQName >+= \top ->
let ls = buildLocals def
ps' = map (buildIParam dem) $ genPs ++ map fst ps in
if top /= Nothing && top == combQName iExpr
-- if the top rule is simply a function call not a case expression,
-- it can be renamed and used as the public function
-- so we don't generate too many extra functions
then modifyTopRule (\name (_, _, r) -> (buildName FuncId name, v, f ps' ls r))
else addRule_ (buildName FuncId) v $ IRule ps' ls iExpr
where
combQName e = case e of
IComb _ qName _ -> Just qName
_ -> Nothing
f ps' ls r = addLocals ls (setParams ps' r)
--- If a variable is not used it is made anonymous
buildIParam :: DemandedEnv -> VarIndex -> IParam
buildIParam dem v | v `elemRBT` dem = IParam v
| otherwise = IAnonParam
--- Extracts locals from environment
buildLocals :: DefinedEnv -> [ILocal]
buildLocals def = map (uncurry ILocal) $ fmToList def
--- Builds an ICurry expression from an Annotated FlatCurry expression, possibly
--- adding new helper functions
genIExpr :: AExpr TypeExpr -> VE
genIExpr (AVar _ v) = returnVE (IVar v) $ demand v emptyEnv
genIExpr (ALit _ lit) = returnVE (ILit lit) emptyEnv
genIExpr (AComb _ t aName ps) =
unzipMapES genIExpr ps >+= \(iPs, envs) ->
-- adds generator parameters to the function
genCombGens t aName >+= \(pGens, envs') ->
-- adds a unique parameter for calls to `global`
genGlobalId (fst aName) >+= \globalId ->
let ps' = pGens ++ globalId ++ iPs in
returnVE (buildIComb t qName ps') $ combineEnvs (envs' ++ envs)
where
(mod, name) = fst aName
qName = (mod, buildFuncName t name)
genIExpr (ALet _ ls expr) =
unzipMapES genLs ls >+= \ve ->
genIExpr expr >+= \(iExpr, env) ->
-- let's are saved in VE since they can only occur at the top of functions
-- or branches in ICurry
returnVE iExpr $ combineLocalEnvs ve env
genIExpr (AFree _ fs expr) =
unzipMapES genFree fs >+= \ve ->
genIExpr expr >+= \(iExpr, env) ->
returnVE iExpr $ combineLocalEnvs ve env
genIExpr (AOr _ expr1 expr2) =
genIExpr expr1 >+= \(iExpr1, env1) ->
genIExpr expr2 >+= \(iExpr2, env2) ->
let env = combineEnvs [env1, env2]
ors1 = unpackIOr iExpr1
ors2 = unpackIOr iExpr2 in
returnVE (IOr $ ors1 ++ ors2) env
genIExpr (ACase _ _ expr bs) =
-- a new function is generated for each case
newFuncId >+= \fId ->
newVarId >+= \newCExprId ->
getFuncName >+= \name ->
genIExpr expr >+= \(iExpr, (demE, defE)) ->
unzipMapES genIBranch bs >+= \(iBs, demBs) ->
-- VE information is combined from all branches
let demB = combineDemanded demBs
dem' = combineDemanded [demB, demE]
demBList = setRBT2list (demand' cExprId demB)
demList' = setRBT2list dem'
pExprs = map IVar demList'
-- if the expression being `case'd on` is not a variable, create a new
-- locale one
cExprId = fromMaybe newCExprId (varFromIExpr iExpr)
cExprLoc = if cExprId == newCExprId then [ILocal cExprId iExpr] else []
ls' = cExprLoc ++ buildLocals defE
cName = buildName (FuncHnfId fId) name
l = buildLitTemplate (annExpr expr)
iRule = ICase cName params ls' demBList cExprId l iBs
params = map IParam demList' in
addRule (buildName (FuncCaseId fId)) Private iRule >+= \qName ->
returnVE (IComb FuncCall qName pExprs) (dem', emptyFM (<))
genIExpr (ATyped _ expr _) = genIExpr expr
--- In case of a call to `global` add unique id as an additional parameter to
--- distinguish between calls
genGlobalId :: QName -> IS [IExpr]
genGlobalId qName | qName == ("Global", "global") = f <$> nextGlobalId
| otherwise = returnES []
where
f Nothing = []
f (Just (mod, id)) = [IString mod, ILit (Intc id)]
--- Returns the variable id if the expression is a straight variable
varFromIExpr :: IExpr -> Maybe VarIndex
varFromIExpr expr = case expr of
IVar v -> Just v
_ -> Nothing
--- Returns a literal (with an arbitrary value) if the input type is a literal
buildLitTemplate :: TypeExpr -> Maybe Literal
buildLitTemplate (TVar _) = error "GenICurry.buildLitTemplate: unreachable"
buildLitTemplate (FuncType _ _) = Nothing
buildLitTemplate (TCons qName _) = case qName of
("Prelude", "Int") -> Just (Intc 42)
("Prelude", "Float") -> Just (Floatc 42)
("Prelude", "Char") -> Just (Charc '*')
_ -> Nothing
--- Returns a prefixed function/constructor name for a CombType
buildFuncName :: CombType -> String -> String
buildFuncName t name = if isCombTypeAnyFuncCall t
then buildName FuncId name
else buildName ConsId name
--- Returns an IExpr for a call, replacing lists with their IExpr equivalent IList
buildIComb :: CombType -> QName -> [IExpr] -> IExpr
buildIComb t qName ps = case t of
ConsCall -> buildICombCons qName ps
_ -> IComb t qName ps
--- Returns an IExpr for a constructor call, replacing lists with their IExpr
--- equivalent IList
buildICombCons :: QName -> [IExpr] -> IExpr
buildICombCons qName ps = case qName of
("Prelude", "c_[]") -> IList []
("Prelude", "c_:") -> buildIList qName ps
_ -> IComb ConsCall qName ps
--- 'Compresses' an IExpr list by combining "x : IList xs" to "IList (x:xs)" or
--- "IString xs" if xs are characters
buildIList :: QName -> [IExpr] -> IExpr
buildIList qName ps = case ps of
[ILit (Charc c), IList []] -> IString [c]
[ILit (Charc c), IString s] -> IString (c:s)
[x , IList xs] -> IList (x:xs)
_ -> IComb ConsCall qName ps
--- Returns a list of generator IExpr's needed for a function call and their VarEnv's
genCombGens :: CombType -> (QName, TypeExpr) -> IS ([IExpr], [VarEnv])
genCombGens t (qName, ty) = if isCombTypeAnyFuncCall t
then getFuncType qName >+=
inferCombGens ty >+=
unzipMapES (genIGen IVar)
else returnES ([], [])
--- Returns the list of type variable expressions needed to call a function
inferCombGens :: TypeExpr -> TypeExpr -> IS [TypeExpr]
inferCombGens callTy fnTy = case unify eqs of
Left err -> failES $ show err
Right subst -> returnES $ map (toTypeExpr . fromJust . lookupFM subst) tArgs
where
minId = minFreeId (typeArgs callTy)
fnTy' = updTVars (TVar . (minId+)) fnTy
eqs = [(fromTypeExpr fnTy', fromTypeExpr callTy)]
tArgs = typeArgs fnTy'
--- Transforms a type expression into the IExpr representing its generator call.
--- The function parameter indicates whether a variable should be an IVar or IGen.
genIGen :: (VarIndex -> IExpr) -> TypeExpr -> VE
genIGen genV (TVar tVar) =
getGenVar tVar >+= \var ->
case var of
Nothing -> returnVE (INoGen "Unknown") emptyEnv
Just v -> returnVE (genV v) $ demand v emptyEnv
genIGen _ (FuncType _ _) = returnVE (INoGen "Function") emptyEnv
genIGen _ (TCons tName tys)
| mod == "Prelude" && name `elem` lits = returnVE (INoGen name) emptyEnv
| otherwise =
unzipMapES (genIGen IVar) tys >+= \(iExprs, envs) ->
returnVE (IComb FuncCall qName iExprs) $ combineEnvs envs
where
(mod, name) = tName
qName = (mod, buildName GenId name)
lits = ["Int", "Float", "Char", "IO"]
genLs :: ((VarIndex, TypeExpr), AExpr TypeExpr) -> IS ((VarIndex, IExpr), VarEnv)
genLs ((v, _), expr) = genIExpr expr >+= \(iExpr, env) ->
returnES ((v, iExpr), env)
genFree :: (VarIndex, TypeExpr) -> IS ((VarIndex, IExpr), VarEnv)
genFree (v, ty) = genIGen IGen ty >+= \(iExpr, env) ->
returnES ((v, iExpr), env)
unpackIOr :: IExpr -> [IExpr]
unpackIOr expr = case expr of
IOr l -> l
_ -> [expr]
--- Transforms an ABranchExpr into an IBranch
genIBranch :: ABranchExpr TypeExpr -> IS (IBranch, DemandedEnv)
genIBranch (ABranch p expr) =
genIExpr expr >+= \(iExpr, (dem, def)) ->
let (p', vars) = buildIPattern dem p in
returnES (IBranch p' (buildLocals def) iExpr, foldr deleteRBT dem vars)
--- Transforms an APattern into an IPattern
buildIPattern :: DemandedEnv -> APattern a -> (IPattern, [VarIndex])
buildIPattern dem (APattern _ ((mod, name), _) ps) = (IPattern qName ps', vars)
where
qName = (mod, buildName ConsId name)
ps' = map f ps
vars = map (\(IParam v) -> v) $ filter (/=IAnonParam) ps'
f (v, _) | v `elemRBT` dem = IParam v
| otherwise = IAnonParam
buildIPattern _ (ALPattern _ lit) = (ILPattern lit, [])
------------------------------------------
--- helper functions
unzipMapES :: (a -> ES e s (b, c)) -> [a] -> ES e s ([b], [c])
unzipMapES f l = unzip <$> mapES f l
isCombTypeAnyFuncCall :: CombType -> Bool
isCombTypeAnyFuncCall t = isCombTypeFuncCall t || isCombTypeFuncPartCall t
setParams :: [IParam] -> IRule -> IRule
setParams _ (IExternal _ _) = error $ "Cam.GenICurry.setParams: "
++ "external function"
setParams ps (IRule _ ls expr) = IRule ps ls expr
setParams ps (ICase cName _ ls ps' e l bs) = ICase cName ps ls ps' e l bs
addLocals :: [ILocal] -> IRule -> IRule
addLocals _ (IExternal _ _) = error $ "Cam.GenICurry.addLocals: "
++ "external function"
addLocals ls (IRule ps ls' expr) = IRule ps (ls'++ls) expr
addLocals ls (ICase cName ps ls' ps' e l bs) = ICase cName ps (ls'++ls) ps' e l bs
typeArgs :: TypeExpr -> [TVarIndex]
typeArgs = sortBy (<) . nub . trTypeExpr (:[]) (const concat) (++)
minFreeId :: [Int] -> Int
minFreeId [] = 0
minFreeId l@(_:_) = maximum l + 1
------------------------------------------
type VE = IS (IExpr, VarEnv)
--- Contains all variables that are used by an associated expression, but not
--- defined by it
type DemandedEnv = SetRBT VarIndex
--- Contains all variable definitions introduced by an associated expression
type DefinedEnv = FM VarIndex IExpr
type VarEnv = (DemandedEnv, DefinedEnv)
returnVE :: IExpr -> VarEnv -> VE
returnVE expr env = returnES (expr, env)
emptyEnv :: VarEnv
emptyEnv = (emptySetRBT (<), emptyFM (<))
demand :: VarIndex -> VarEnv -> VarEnv
demand v (dem, def) = (insertRBT v dem, def)
demand' :: VarIndex -> DemandedEnv -> DemandedEnv
demand' v dem = insertRBT v dem
combineDemanded :: [DemandedEnv] -> DemandedEnv
combineDemanded = foldr unionRBT (emptySetRBT (<))
combineDefined :: [DefinedEnv] -> DefinedEnv
combineDefined = foldr plusFM (emptyFM (<))
combineEnvs :: [VarEnv] -> VarEnv
combineEnvs envs = (combineDemanded dems, combineDefined defs)
where
(dems, defs) = unzip envs
combineLocalEnvs :: ([(VarIndex, IExpr)], [VarEnv]) -> VarEnv -> VarEnv
combineLocalEnvs (iLs, envs) env = (dem', def')
where
(dem, def) = combineEnvs (env:envs)
dem' = foldl (\d (v, _) -> deleteRBT v d) dem iLs
def' = addListToFM def iLs
------------------------------------------
--- Types used to identify the prefix of a prefixed id
data IdType = DataId | ConsId | FuncId | FuncCaseId Int | FuncHnfId Int | GenId
--- Prefixes a name
buildName :: IdType -> String -> String
buildName id name = pre ++ name
where
pre = case id of
DataId -> "d_"
ConsId -> "c_"
FuncId -> "f_"
FuncCaseId n -> 'f':show n ++ "_"
FuncHnfId n -> 'h':show n ++ "_"
GenId -> "g_"
------------------------------------------
-- from FlatCurry/Annotated/TypeInference.curry
fromTypeExpr :: TypeExpr -> Term String
fromTypeExpr (TVar n) = TermVar n
fromTypeExpr (TCons t vs) = TermCons (fromQName t) (map fromTypeExpr vs)
fromTypeExpr (FuncType a b) = TermCons "->" [fromTypeExpr a, fromTypeExpr b]
toTypeExpr :: Term String -> TypeExpr
toTypeExpr (TermVar n) = TVar n
toTypeExpr (TermCons t vs)
| t == "->" = FuncType (toTypeExpr (vs !! 0)) (toTypeExpr (vs !! 1))
| otherwise = TCons (toQName t) (map toTypeExpr vs)
fromQName :: QName -> String
fromQName (mod, typ) = mod ++ ";" ++ typ
toQName :: String -> QName
toQName str = (fst split, snd split)
where split = splitFirst str ';'
splitFirst :: [a] -> a -> ([a], [a])
splitFirst [] _ = ([], [])
splitFirst (x:xs) c
| x == c = ([], xs)
| otherwise = (x : fst rest, snd rest)
where rest = splitFirst xs c
--- Helper module for GenICurry provides an ErrorState with some state
--- information and functions to use it
module ICurry.ISState
( module ErrorState
, module ICurry.ISState
, liftE, liftM, whenES
) where
import FlatCurry.Types (QName, TVarIndex, TypeExpr, VarIndex, Visibility)
import ErrorState
import FiniteMap (FM, emptyFM, listToFM, lookupFM)
import Maybe ((>>-))
import ICurry.Types (IRule)
import ICurry.Utils (liftE, liftM, whenES)
--- A State holds the following information:
--- - modName: The name of the module
--- - curNextGlobalId: Used to implement the Global module, each call of
--- `global` gets its own (module-)unique id
--- - progEnv: Type information for the module as provided by FlatCurry.Annotated
--- - curFuncName: The name of the function being currently processed
--- - curNextVarId: Provides fresh variable ids, holds the next free id
--- - curNextFuncId Provides fresh function ids, holds the next free id
--- - curGenVars: Holds the generator parameters for the current function
--- - curRules: All the rules generated for the current functino so far
--- (name, visibility, rule)
data ISState = ISState
{ modName :: String
, curNextGlobalId :: Maybe Int
, progEnv :: FM QName TypeExpr
, curFuncName :: Maybe String
, curNextVarId :: VarIndex
, curNextFuncId :: Int
, curGenVars :: FM TVarIndex VarIndex
, curRules :: [(String, Visibility, IRule)]
}
type IS a = ES String ISState a
--- Initializes an ISState, enableGlobal determines whether calls to `global`
--- should get a unique id
initIS :: Bool -> String -> FM QName TypeExpr -> ISState
initIS enableGlobal mod pEnv = ISState
{ modName = mod
, curNextGlobalId = if enableGlobal then Just 1 else Nothing
, progEnv = pEnv
, curFuncName = Nothing
, curNextVarId = 0
, curNextFuncId = 0
, curGenVars = emptyFM (<)
, curRules = []
}
--- Returns the name of the module
getModule :: IS String
getModule = modName <$> gets
--- Returns the name of the current module and a fresh global id if global ids
--- are enabled
nextGlobalId :: IS (Maybe (String, Int))
nextGlobalId =
curNextGlobalId <$> gets >+= \mGId ->
case mGId of
Nothing -> returnES Nothing
Just gId ->
getModule >+= \mod ->
modify (\s -> s { curNextGlobalId = Just (gId+1) }) >+
returnES (Just (mod, gId))
--- Returns the type of a function
getFuncType :: QName -> IS TypeExpr
getFuncType qName =
progEnv <$> gets >+= \env ->
case lookupFM env qName of
Nothing -> error $ "ICurry.ISState.getFuncType: not found: " ++ show qName
Just ty -> returnES ty
--- Sets a new current function with a new name and id
newFunc :: String -> VarIndex -> IS ()
newFunc name nextId = modify (\s -> s
{ curFuncName = Just name
, curNextVarId = nextId
, curNextFuncId = 0
, curGenVars = emptyFM (<)
, curRules = []
})
--- Returns the name of the current function
getFuncName :: IS String
getFuncName =
curFuncName <$> gets >+= \mName ->
case mName of
Nothing -> error "ICurry.IS.State.getFuncName: no func name set"
Just name -> returnES name
--- Returns a fresh variable id
newVarId :: IS VarIndex
newVarId =
curNextVarId <$> gets >+= \newVar ->
modify (\s -> s { curNextVarId = newVar + 1 }) >+
returnES newVar
--- Returns a fresh function id
newFuncId :: IS Int
newFuncId =
curNextFuncId <$> gets >+= \newId ->
modify (\s -> s { curNextFuncId = newId + 1 }) >+
returnES newId
--- Sets the generator parameters of the current function
setGenVars :: [(TVarIndex, VarIndex)] -> IS ()
setGenVars vars = modify (\s -> s { curGenVars = listToFM (<) vars })
--- Returns the generator parameter for a type variable
getGenVar :: TVarIndex -> IS (Maybe VarIndex)
getGenVar tVar = flip lookupFM tVar . curGenVars <$> gets
--- Adds a rule to the current function
--- f builds the name for the rule using the functions original name
--- Returns the QName of the new rule
addRule :: (String -> String) -> Visibility -> IRule -> IS QName
addRule f v rule =
f <$> getFuncName >+= \name ->
getModule >+= \mod ->
modify (\s -> s { curRules = (name, v, rule) : curRules s }) >+
returnES (mod, name)
--- Adds a rule to the current function
--- f builds the name for the rule using the functions original name
addRule_ :: (String -> String) -> Visibility -> IRule -> IS ()
addRule_ f v rule = addRule f v rule >+ returnES ()
--- Returns the QName of the rule last added
getTopRuleQName :: IS (Maybe QName)
getTopRuleQName =
curRules <$> gets >+= \rs ->
case rs of
[] -> returnES Nothing
((name, _, _):_) -> getModule >+= \mod ->
returnES $ Just (mod, name)
--- Modifies the rule last added
modifyTopRule :: (String -> (String, Visibility, IRule) -> (String, Visibility, IRule))
-> IS ()
modifyTopRule f =
getFuncName >+= \name ->
modify (\s -> s { curRules = modTop name (curRules s) })
where
modTop _ [] = error "ICurry.IS.State.modifyTopRule: empty rule list"
modTop name (r : rs) = f name r : rs
--- Returns all rules of the current function
getRules :: IS [(String, Visibility, IRule)]
getRules =
curRules <$> gets >+= \rs ->
modify (\s -> s { curRules = [] }) >+
returnES rs
--- Pretty printer for ICurry, prints a syntax based loosely based on curry syntax
--- Variables in angle brackets stand for generators from parameters
module ICurry.Pretty(ppIProg) where
import FlatCurry.Types (Literal(..), QName, VarIndex)
import Pretty
import ICurry.Types
ppIProg :: IProg -> Doc
ppIProg (IProg name is ds fs) = text "module"
<+> text name
<+> text "where"
<$+$> (vsep . map ppImport) is