Add top-level signatures and general code cleanup

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -6,30 +6,35 @@ module GF.Compile.GrammarToCanonical(
        ) where
 import Data.List(nub,partition)
 import qualified Data.Map as M
+import Data.Maybe(fromMaybe)
 import qualified Data.Set as S
 import GF.Data.ErrM
 import GF.Text.Pretty
-import GF.Grammar.Grammar
+import GF.Grammar.Grammar as G
 import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
 import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt,sortRec)
 import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,prefixIdent,showIdent,isWildIdent)
-import GF.Infra.Option(optionsPGF)
+import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,{-prefixIdent,-}showIdent,isWildIdent)
+import GF.Infra.Option(Options,optionsPGF)
 import PGF.Internal(Literal(..))
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
 import GF.Grammar.Canonical as C
-import Debug.Trace
+import System.FilePath ((</>), (<.>))
+import Debug.Trace(trace,traceShow)
+
 
 -- | Generate Canonical code for the named abstract syntax and all associated
 -- concrete syntaxes
+grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
 grammar2canonical opts absname gr =
    Grammar (abstract2canonical absname gr)
            (map snd (concretes2canonical opts absname gr))
 
 -- | Generate Canonical code for the named abstract syntax
+abstract2canonical :: ModuleName -> G.Grammar -> Abstract
 abstract2canonical absname gr =
     Abstract (modId absname) (convFlags gr absname) cats funs
   where
@@ -44,6 +49,7 @@ abstract2canonical absname gr =
     convHypo (bt,name,t) =
       case typeForm t of
         ([],(_,cat),[]) -> gId cat -- !!
+        tf -> error $ "abstract2canonical convHypo: " ++ show tf
 
     convType t =
       case typeForm t of
@@ -57,15 +63,17 @@ abstract2canonical absname gr =
 
 -- | Generate Canonical code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
+concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
 concretes2canonical opts absname gr =
   [(cncname,concrete2canonical gr cenv absname cnc cncmod)
      | let cenv = resourceValues opts gr,
        cnc<-allConcretes gr absname,
-       let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
+       let cncname = "canonical" </> render cnc <.> "gf"
            Ok cncmod = lookupModule gr cnc
   ]
 
 -- | Generate Canonical GF for the given concrete module.
+concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
 concrete2canonical gr cenv absname cnc modinfo =
   Concrete (modId cnc) (modId absname) (convFlags gr cnc)
       (neededParamTypes S.empty (params defs))
@@ -85,6 +93,11 @@ concrete2canonical gr cenv absname cnc modinfo =
         else let ((got,need),def) = paramType gr q
              in def++neededParamTypes (S.union got have) (S.toList need++qs)
 
+toCanonical :: G.Grammar
+              -> ModuleName
+              -> GlobalEnv
+              -> (Ident, Info)
+              -> [(S.Set QIdent, Either LincatDef LinDef)]
 toCanonical gr absname cenv (name,jment) =
   case jment of
     CncCat (Just (L loc typ)) _ _ pprn _ ->
@@ -114,6 +127,7 @@ toCanonical gr absname cenv (name,jment) =
     unAbs n (Abs _ _ t) = unAbs (n-1) t
     unAbs _ t = t
 
+tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
 tableTypes gr ts = S.unions (map tabtys ts)
   where
     tabtys t =
@@ -122,6 +136,7 @@ tableTypes gr ts = S.unions (map tabtys ts)
         T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
         _ -> collectOp tabtys t
 
+paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
 paramTypes gr t =
   case t of
     RecType fs -> S.unions (map (paramTypes gr.snd) fs)
@@ -140,11 +155,12 @@ paramTypes gr t =
                  Ok (_,ResParam {}) -> S.singleton q
                  _ -> ignore
 
-    ignore = trace ("Ignore: "++show t) S.empty
-
+    ignore = trace ("Ignore: " ++ show t) S.empty
 
+convert :: G.Grammar -> Term -> LinValue
 convert gr = convert' gr []
 
+convert' :: G.Grammar -> [Ident] -> Term -> LinValue
 convert' gr vs = ppT
   where
     ppT0 = convert' gr vs
@@ -169,13 +185,13 @@ convert' gr vs = ppT
         Con c -> ParamConstant (Param (gId c) [])
         Sort k -> VarValue (gId k)
         EInt n -> LiteralValue (IntConstant n)
-        Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
-        QC (m,n) -> ParamConstant (Param ((gQId m n)) [])
+        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
+        QC (m,n) -> ParamConstant (Param (gQId m n) [])
         K s -> LiteralValue (StrConstant s)
         Empty -> LiteralValue (StrConstant "")
         FV ts -> VariantValue (map ppT ts)
         Alts t' vs -> alts vs (ppT t')
-        _ -> error $ "convert' "++show t
+        _ -> error $ "convert' ppT: " ++ show t
 
     ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
 
@@ -193,7 +209,7 @@ convert' gr vs = ppT
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
-        PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
+        PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps))
         PR r -> RecordPattern (fields r) {-
         PW -> WildPattern
         PV x -> VarP x
@@ -202,6 +218,7 @@ convert' gr vs = ppT
         PFloat x -> Lit (show x)
         PT _ p -> ppP p
         PAs x p -> AsP x (ppP p) -}
+        _ -> error $ "convert' ppP: " ++ show p
       where
         fields = map field . filter (not.isLockLabel.fst)
         field (l,p) = RecordRow (lblId l) (ppP p)
@@ -218,12 +235,12 @@ convert' gr vs = ppT
         pre Empty = [""]  -- Empty == K ""
         pre (Strs ts) = concatMap pre ts
         pre (EPatt p) = pat p
-        pre t = error $ "pre "++show t
+        pre t = error $ "convert' alts pre: " ++ show t
 
         pat (PString s) = [s]
         pat (PAlt p1 p2) = pat p1++pat p2
         pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
-        pat p = error $ "pat "++show p
+        pat p = error $ "convert' alts pat: "++show p
 
     fields = map field . filter (not.isLockLabel.fst)
     field (l,(_,t)) = RecordRow (lblId l) (ppT t)
@@ -236,6 +253,7 @@ convert' gr vs = ppT
                  ParamConstant (Param p (ps++[a]))
                _ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
 
+concatValue :: LinValue -> LinValue -> LinValue
 concatValue v1 v2 =
   case (v1,v2) of
     (LiteralValue (StrConstant ""),_) -> v2
@@ -243,8 +261,10 @@ concatValue v1 v2 =
     _ -> ConcatValue v1 v2
 
 -- | Smart constructor for projections
-projection r l = maybe (Projection r l) id (proj r l)
+projection :: LinValue -> LabelId -> LinValue
+projection r l = fromMaybe (Projection r l) (proj r l)
 
+proj :: LinValue -> LabelId -> Maybe LinValue
 proj r l =
   case r of
     RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
@@ -253,6 +273,7 @@ proj r l =
     _ -> Nothing
 
 -- | Smart constructor for selections
+selection :: LinValue -> LinValue -> LinValue
 selection t v =
   -- Note: impossible cases can become possible after grammar transformation
   case t of
@@ -276,13 +297,16 @@ selection t v =
         (keep,discard) = partition (mightMatchRow v) r
     _ -> Selection t v
 
+impossible :: LinValue -> LinValue
 impossible = CommentedValue "impossible"
 
+mightMatchRow :: LinValue -> TableRow rhs -> Bool
 mightMatchRow v (TableRow p _) =
   case p of
     WildPattern -> True
     _ -> mightMatch v p
 
+mightMatch :: LinValue -> LinPattern -> Bool
 mightMatch v p =
   case v of
     ConcatValue _ _ -> False
@@ -294,16 +318,18 @@ mightMatch v p =
     RecordValue rv ->
       case p of
         RecordPattern rp ->
-          and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
+          and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
         _ -> False
     _ -> True
 
+patVars :: Patt -> [Ident]
 patVars p =
   case p of
     PV x -> [x]
     PAs x p -> x:patVars p
     _ -> collectPattOp patVars p
 
+convType :: Term -> LinType
 convType = ppT
   where
     ppT t =
@@ -315,9 +341,9 @@ convType = ppT
         Sort k -> convSort k
 --      EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
         FV (t:ts) -> ppT t -- !!
-        QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
-        Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
-        _ -> error $ "Missing case in convType for: "++show t
+        QC (m,n) -> ParamType (ParamTypeId (gQId m n))
+        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
+        _ -> error $ "convType ppT: " ++ show t
 
     convFields = map convField . filter (not.isLockLabel.fst)
     convField (l,r) = RecordRow (lblId l) (ppT r)
@@ -326,15 +352,20 @@ convType = ppT
                    "Float" -> FloatType
                    "Int" -> IntType
                    "Str" -> StrType
-                   _ -> error ("convSort "++show k)
+                   _ -> error $ "convType convSort: " ++ show k
 
+toParamType :: Term -> ParamType
 toParamType t = case convType t of
                   ParamType pt -> pt
-                  _ -> error ("toParamType "++show t)
+                  _ -> error $ "toParamType: " ++ show t
 
+toParamId :: Term -> ParamId
 toParamId t = case toParamType t of
                    ParamTypeId p -> p
 
+paramType :: G.Grammar
+             -> (ModuleName, Ident)
+             -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
 paramType gr q@(_,n) =
     case lookupOrigInfo gr q of
       Ok (m,ResParam (Just (L _ ps)) _)
@@ -342,7 +373,7 @@ paramType gr q@(_,n) =
          ((S.singleton (m,n),argTypes ps),
           [ParamDef name (map (param m) ps)]
          )
-       where name = (gQId m n)
+       where name = gQId m n
       Ok (m,ResOper  _ (Just (L _ t)))
         | m==cPredef && n==cInts ->
            ((S.empty,S.empty),[]) {-
@@ -350,10 +381,10 @@ paramType gr q@(_,n) =
             [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
         | otherwise ->
            ((S.singleton (m,n),paramTypes gr t),
-            [ParamAliasDef ((gQId m n)) (convType t)])
+            [ParamAliasDef (gQId m n) (convType t)])
       _ -> ((S.empty,S.empty),[])
   where
-    param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
+    param m (n,ctx) = Param (gQId m n) [toParamId t|(_,_,t)<-ctx]
     argTypes = S.unions . map argTypes1
     argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
 
@@ -364,7 +395,8 @@ lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
 modId :: ModuleName -> C.ModId
 modId (MN m) = ModId (ident2raw m)
 
-class FromIdent i where gId :: Ident -> i
+class FromIdent i where
+  gId :: Ident -> i
 
 instance FromIdent VarId where
   gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
@@ -374,14 +406,19 @@ instance FromIdent CatId where gId = CatId . ident2raw
 instance FromIdent ParamId where gId = ParamId . unqual
 instance FromIdent VarValueId where gId = VarValueId . unqual
 
-class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
+class FromIdent i => QualIdent i where
+  gQId :: ModuleName -> Ident -> i
 
-instance QualIdent ParamId    where gQId m n = ParamId (qual m n)
+instance QualIdent ParamId where gQId m n = ParamId (qual m n)
 instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
 
+qual :: ModuleName -> Ident -> QualId
 qual m n = Qual (modId m) (ident2raw n)
+
+unqual :: Ident -> QualId
 unqual n = Unqual (ident2raw n)
 
+convFlags :: G.Grammar -> ModuleName -> Flags
 convFlags gr mn =
   Flags [(rawIdentS n,convLit v) |
          (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]