Common.hs 9.83 KB
Newer Older
marton bognar's avatar
marton bognar committed
1
2
{-# OPTIONS_GHC -Wall #-}

3
module Variable.Common (getEnvFunctions, freeVarFunctions, mappingFunctions, sortNameForIden, firstToVarParams, dropFold, ExternalFunctions(..), applyInhCtxsToAttrs, inhCtxsForSortName) where
marton bognar's avatar
marton bognar committed
4
5
6
7
8
9
10
11

import Data.List
import Data.Maybe

import Program
import GeneralTerms
import Utility

12
data ExternalFunctions = EF {
13
14
  paramForCtor :: ConstructorDef -> [Parameter],
  freeVarExprForVarCtor :: String -> Expression,
15
  applyInhCtxsToAttrs :: SortName -> ConstructorDef -> (IdenName, [AttributeDef]) -> [(SortName, [Context])] -> Expression,
16
  includeBinders :: Bool
17
18
19
20
}

-- * Types
-- ----------------------------------------------------------------------------
marton bognar's avatar
marton bognar committed
21

marton bognar's avatar
marton bognar committed
22
-- | ??
marton bognar's avatar
marton bognar committed
23
getEnvFunctions :: Language -> [Function]
marton bognar's avatar
marton bognar committed
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
getEnvFunctions (nsd, sd, _, _)
  = let ctxsBySname = map snameAndCtxs sd
    in concatMap (\sort ->
      let synCtxs = [SYN x y | SYN x y <- sctxs sort]
      in if null synCtxs then [] else
      map (\ctor ->
        generateSortSynSystemOneConstructor (sname sort) nsd ctxsBySname ctor (head synCtxs)
      ) (sctors sort)
    ) sd
    where
      generateSortSynSystemOneConstructor :: SortName -> [NamespaceDef] -> [(SortName, [Context])] -> ConstructorDef -> Context -> Function
      generateSortSynSystemOneConstructor sname _ _ (MkVarConstructor ctorName _) _
        = Fn ("addToEnvironment" ++ sname) [([ConstrParam ctorName [VarParam "var"], VarParam "c"], VarExpr "c")]
      generateSortSynSystemOneConstructor sname nsd ctxsBySname ctor ctx
        = Fn ("addToEnvironment" ++ sname ++ xinst ctx) [([ConstrParam ctorName (firstToVarParams sorts ++ [VarParam "_" | _ <- hTypes]), VarParam "c"], getEnvFunctionGenerate)]
          where
            filteredSnameAndCtxs = filterCtxsByNamespace (xnamespace ctx) ctxsBySname
            ctorName = cname ctor
            sorts = csorts ctor
            hTypes = cnatives ctor
            attrs = cattrs ctor
marton bognar's avatar
marton bognar committed
45

marton bognar's avatar
marton bognar committed
46
47
48
49
50
51
52
53
54
55
56
            getEnvFunctionGenerate :: Expression
            getEnvFunctionGenerate
              | null $ fromJust (lookup "lhs" allrules) = VarExpr "c"
              | otherwise = navigateAttrs start
              where
                allrules = collectRulesSyn
                start = fromJust (
                  find
                    (\x -> linst (fst x) == xinst ctx)
                    (fromJust (lookup "lhs" allrules))
                  )
marton bognar's avatar
marton bognar committed
57

marton bognar's avatar
marton bognar committed
58
59
60
61
62
63
64
65
66
            collectRulesSyn :: [(IdenName, [AttributeDef])]
            collectRulesSyn =
              foldl
                (++)
                [("lhs", [(LeftLHS c, r) | (LeftLHS c, r) <- attrs])]
                (map (\(iden, _) -> [collectRulesOfIdSyn iden]) sorts)
              where
                collectRulesOfIdSyn :: IdenName -> (IdenName, [AttributeDef])
                collectRulesOfIdSyn iden = (iden, filter (\(LeftSub fieldname _, RightSub _ _) -> fieldname == iden) attrs)
marton bognar's avatar
marton bognar committed
67

marton bognar's avatar
marton bognar committed
68
            navigateAttrs :: AttributeDef -> Expression
69
            navigateAttrs (l, RightAdd expr _) = ConstrInst ("S" ++ xnamespace ctx) [navigateAttrs (l, expr)]
marton bognar's avatar
marton bognar committed
70
71
72
73
74
75
76
77
            navigateAttrs (LeftLHS _, RightLHS _) = VarExpr "c"
            navigateAttrs (LeftSub _ _, RightLHS _) = VarExpr "c"
            navigateAttrs (_, RightSub iden _)
              | isJust newrule = FnCall functionName [VarExpr iden, navigateAttrs (fromJust newrule)]
              | otherwise = FnCall functionName [VarExpr iden, VarExpr "c"]
              where
                newrule = find (\(l, _) -> liden l == iden) attrs
                functionName = "addToEnvironment" ++ fromJust (lookup iden sorts) ++ xinst ctx
marton bognar's avatar
marton bognar committed
78

79
80
-- * Free variables
-- ----------------------------------------------------------------------------
marton bognar's avatar
marton bognar committed
81

82
83
84
85
-- | Generate free variable functions for every sort that has access to variable
-- constructors
freeVarFunctions :: Language -> ExternalFunctions -> [Function]
freeVarFunctions (_, sd, _, _) ef =
86
  let ctxsBySname = map snameAndCtxs sd
87
88
89
90
91
92
93
94
95
96
      varAccessBySname = varAccessBySortName sd
      sortsWithVarAccess = filter (\(MkDefSort sname _ _ _) -> isJust (lookup sname varAccessBySname)) sd
  in map (\sort ->
    Fn ("freeVariables" ++ sname sort)
    (map (\ctor ->
      (VarParam "c" : paramForCtor ef ctor,
      case ctor of
        (MkVarConstructor name _)
          -> freeVarExprForVarCtor ef name
        _
97
98
99
100
101
102
          -> FnCall "nub" [
              FnCall "concat"
                [ListExpr (
                  freeVariableCallListForCtor ef (sname sort) ctor ctxsBySname varAccessBySname
                )]
             ]
103
      )
104
105
    ) (sctors sort))
  ) sortsWithVarAccess
marton bognar's avatar
marton bognar committed
106
  where
107
108
109
110
111
    -- | Generate a list of expressions, that when concatenated together give
    -- the union of free variables for a given constructor (free variable
    -- calls for every identifier of a sort that has access to variables)
    freeVariableCallListForCtor :: ExternalFunctions -> SortName -> ConstructorDef -> [(SortName, [Context])] -> [(SortName, Bool)] -> [Expression]
    freeVariableCallListForCtor ef sname ctor ctxsBySname varAccessBySname
marton bognar's avatar
marton bognar committed
112
      = let folds = dropFold $ cfolds ctor
113
            lists = clists ctor
marton bognar's avatar
marton bognar committed
114
            idensAndAttrs = attrsByIden ctor
115
116
            callList = concatMap (
              \(iden, iattrs) ->
117
                let addedBinders = (applyInhCtxsToAttrs ef) sname ctor (iden, iattrs) ctxsBySname
118
                    sortNameOfIden = sortNameForIden iden ctor
119
120
                in
                  if fromJust (lookup sortNameOfIden varAccessBySname)
marton bognar's avatar
marton bognar committed
121
                  then if iden `elem` map fst folds
122
                    then [FnCall "foldMap" [FnCall ("freeVariables" ++ sortNameOfIden) [addedBinders], VarExpr iden]]
marton bognar's avatar
marton bognar committed
123
                    else if iden `elem` map fst lists
124
125
                      then [FnCall "concatMap" [FnCall ("freeVariables" ++ sortNameOfIden) [addedBinders], VarExpr iden]]
                      else [FnCall ("freeVariables" ++ sortNameOfIden) (addedBinders : [VarExpr iden])]
126
127
128
                  else []
              ) idensAndAttrs
        in if null callList then [ListExpr []] else callList
marton bognar's avatar
marton bognar committed
129

130
131
132
-- * Mapping functions
-- ----------------------------------------------------------------------------

133
134
135
136
-- | Generate mapping functions for every sort that has access to variable
-- constructors
mappingFunctions :: Language -> ExternalFunctions -> [Function]
mappingFunctions (_, sd, _, _) ef =
137
  let ctxsBySname = map snameAndCtxs sd
138
139
      varAccessBySname = varAccessBySortName sd
      sortsWithVarAccess = filter (\(MkDefSort sname _ _ _) -> isJust (lookup sname varAccessBySname)) sd
marton bognar's avatar
marton bognar committed
140
  in map (
141
142
143
    \(MkDefSort sortName ctxs ctors _) ->
        Fn (mapFnForSortName sortName)
        (map (\ctor ->
marton bognar's avatar
marton bognar committed
144
          (
145
146
147
            [VarParam ("on" ++ namespace) | INH _ namespace <- ctxs]
            ++ [VarParam "c"]
            ++ paramForCtor ef ctor
marton bognar's avatar
marton bognar committed
148
          ,
149
            mappingExprForCtor sortName ctor ctxsBySname varAccessBySname
marton bognar's avatar
marton bognar committed
150
          )
151
152
        ) ctors)
  ) sortsWithVarAccess
marton bognar's avatar
marton bognar committed
153
  where
marton bognar's avatar
marton bognar committed
154
    -- | Return the name of the mapping function for the given sort name
155
    mapFnForSortName :: SortName -> String
156
    mapFnForSortName sname = sname ++ "map"
marton bognar's avatar
marton bognar committed
157

marton bognar's avatar
marton bognar committed
158
159
160
    -- | Generate the map function's body for a given contructor in the sort
    -- (a function call to the namespace's processing function in case of a variable,
    -- and a constructor call with its identifiers also mapped otherwise)
161
    mappingExprForCtor :: SortName -> ConstructorDef -> [(SortName, [Context])] -> [(SortName, Bool)] -> Expression
162
    mappingExprForCtor sortName (MkVarConstructor ctorName _) ctxsBySname _ =
marton bognar's avatar
marton bognar committed
163
      FnCall ("on" ++ xnamespace (head (fromJust (lookup sortName ctxsBySname)))) [ -- TODO: this is a suspicious head call
marton bognar's avatar
marton bognar committed
164
        VarExpr "c",
165
        ConstrInst ctorName [VarExpr "var"]
marton bognar's avatar
marton bognar committed
166
      ]
marton bognar's avatar
marton bognar committed
167
168
169
170
    mappingExprForCtor sortName ctor ctxsBySname varAccessBySname =
      let binder = if includeBinders ef && isBind ctor then [VarExpr "b"] else []
      in
        ConstrInst
171
          (cname ctor)
marton bognar's avatar
marton bognar committed
172
173
174
          (
            binder
            ++ map mapFnCallForIden idensAndAttrs
175
            ++ [VarExpr (x ++ show n) | (x, n) <- zip (cnatives ctor) [1 :: Int ..]]
marton bognar's avatar
marton bognar committed
176
          )
marton bognar's avatar
marton bognar committed
177
      where
marton bognar's avatar
marton bognar committed
178
        idensAndAttrs = attrsByIden ctor
marton bognar's avatar
marton bognar committed
179
180
        folds = dropFold (cfolds ctor)
        lists = clists ctor
marton bognar's avatar
marton bognar committed
181

marton bognar's avatar
marton bognar committed
182
183
184
185
186
        -- | Construct a mapping function call for an identifier
        mapFnCallForIden :: (IdenName, [AttributeDef]) -> Expression
        mapFnCallForIden (iden, idenAttrs)
          = if fromJust (lookup sortNameOfIden varAccessBySname)
              then if iden `elem` map fst folds
187
                then FnCall "fmap" [FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders), VarExpr iden]
marton bognar's avatar
marton bognar committed
188
                else if iden `elem` map fst lists
189
190
191
                  then FnCall "map" [FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders), VarExpr iden]
                  else FnCall (mapFnForSortName sortNameOfIden) (fnCallsForCtxs (fromJust (lookup sortNameOfIden ctxsBySname)) ++ addedBinders ++ [VarExpr iden])
              else VarExpr iden
marton bognar's avatar
marton bognar committed
192
          where
193
            addedBinders = [(applyInhCtxsToAttrs ef) sortName ctor (iden, idenAttrs) ctxsBySname]
194
            sortNameOfIden = sortNameForIden iden ctor
marton bognar's avatar
marton bognar committed
195

marton bognar's avatar
marton bognar committed
196
197
198
199
            -- | Return a function reference for the processing functions
            -- of the namespaces in the list of contexts
            fnCallsForCtxs :: [Context] -> [Expression]
            fnCallsForCtxs ctx = [VarExpr ("on" ++ namespace) | INH _ namespace <- ctx]
marton bognar's avatar
marton bognar committed
200

201
202
203
-- * Helper functions
-- ----------------------------------------------------------------------------

204
-- | Returns the list of inherited contexts for a given sort name
205
inhCtxsForSortName :: SortName -> [(SortName, [Context])] -> [Context]
206
inhCtxsForSortName sname ctxsForSortName = [INH x y | INH x y <- ctxs]
marton bognar's avatar
marton bognar committed
207
  where
208
    ctxs = fromJust (lookup sname ctxsForSortName)
marton bognar's avatar
marton bognar committed
209

210
-- | In a list of tuples, converts the first elements to a list of variable parameters
marton bognar's avatar
marton bognar committed
211
firstToVarParams :: [(String, String)] -> [Parameter]
212
firstToVarParams = map (VarParam . fst)