X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FParsecParser.hs;h=42e21e91132299dd747ef1bfd253f72931ecced4;hp=b5399626ca06bba7edc822c941fba9a91bdb8ef3;hb=10704b34c1928dde3d0ef33fe37c3eb7b948975f;hpb=420a27dc9fb7de5fc6c96fe078ddd4dc87222d44

diff --git a/utils/ext-core/ParsecParser.hs b/utils/ext-core/ParsecParser.hs
index b539962..42e21e9 100644
--- a/utils/ext-core/ParsecParser.hs
+++ b/utils/ext-core/ParsecParser.hs
@@ -1,6 +1,6 @@
-{-# OPTIONS -Wall -Werror -fno-warn-missing-signatures #-}
+{-# OPTIONS -Wall -fno-warn-missing-signatures #-}
 
-module ParsecParser where
+module ParsecParser (parseCore) where
 
 import Core
 import ParseGlue
@@ -8,9 +8,9 @@ import Check
 import PrimCoercions
 
 import Text.ParserCombinators.Parsec
---import Text.ParserCombinators.Parsec.Expr
 import qualified Text.ParserCombinators.Parsec.Token as P
 import Text.ParserCombinators.Parsec.Language
+import Data.Char
 import Data.Ratio
 
 parseCore :: FilePath -> IO (Either ParseError Module)
@@ -32,7 +32,7 @@ coreModuleName = do
    pkgName      <- corePackageName
    char ':'
    (modHierarchy,baseName) <- coreHierModuleNames
-   return (pkgName, modHierarchy, baseName)
+   return $ M (pkgName, modHierarchy, baseName)
 
 corePackageName :: Parser Pname
 -- Package names can be lowercase or uppercase!
@@ -92,25 +92,22 @@ coreQualifiedCon = coreQualifiedGen upperName
  
 coreQualifiedName = coreQualifiedGen identifier
 
-coreQualifiedGen p = do
-  maybeMname <- coreMaybeMname
-  theId      <- p
-  return (maybeMname, theId)
-
-coreMaybeMname = optionMaybe coreMname
-
-coreRequiredQualifiedName = do
-  mname <- coreMname
-  theId <- identifier
-  return (Just mname, theId)
-
-coreMname = do
--- Notice the '^' goes here:
--- it's part of a variable *occurrence*, not a module name.
-  char '^'
-  nm <- try coreModuleName
-  symbol "."
-  return nm
+coreQualifiedGen :: Parser String -> Parser (Mname, Id) 
+coreQualifiedGen p = (try (do
+  packageIdOrVarName <- corePackageName
+  maybeRest <- optionMaybe (char ':' >> coreHierModuleNames)
+  case maybeRest of
+               -- unqualified id, so backtrack
+    Nothing -> pzero
+               -- qualified name, so look for the id part
+    Just (modHierarchy, baseName) -> do
+               char '.'
+               theId <- p
+               return
+                 (Just $ M (packageIdOrVarName, modHierarchy, baseName),
+                  theId))) <|> 
+   -- unqualified name
+   (p >>= (\ res -> return (Nothing, res)))
 
 coreAxiom :: Parser Axiom
 coreAxiom = parens (do
@@ -192,7 +189,8 @@ coreBty = do
              Sym k     -> app k 1 maybeRest "sym"
              Unsafe k  -> app k 2 maybeRest "unsafe"
              LeftCo k  -> app k 1 maybeRest "left"
-             RightCo k -> app k 1 maybeRest "right")
+             RightCo k -> app k 1 maybeRest "right"
+             InstCo k  -> app k 2 maybeRest "inst")
                  where app k arity args _ | length args == arity = k args
                        app _ _ args err = 
                            primCoercionError (err ++ 
@@ -223,33 +221,26 @@ coreTcon =
                                     -- the "try"s are crucial; they force
                                     -- backtracking
            maybeCoercion <- choice [try symCo, try transCo, try unsafeCo,
-                                    try leftCo, rightCo]
+                                    try instCo, try leftCo, rightCo]
            return $ case maybeCoercion of
               TransC  -> Trans (\ [x,y] -> TransCoercion x y)
               SymC    -> Sym (\ [x] -> SymCoercion x)
               UnsafeC -> Unsafe (\ [x,y] -> UnsafeCoercion x y)
               LeftC   -> LeftCo (\ [x] -> LeftCoercion x)
-              RightC  -> RightCo (\ [x] -> RightCoercion x))
+              RightC  -> RightCo (\ [x] -> RightCoercion x)
+              InstC   -> InstCo (\ [x,y] -> InstCoercion x y))
     <|> (coreQualifiedCon >>= (return . ATy . Tcon))
 
-data CoercionTy = TransC | SymC | UnsafeC | LeftC | RightC
+data CoercionTy = TransC | InstC | SymC | UnsafeC | LeftC | RightC
 
-symCo, transCo, unsafeCo :: Parser CoercionTy
+symCo, transCo, unsafeCo, instCo, leftCo, rightCo :: Parser CoercionTy
 -- Would be better not to wire these in quite this way. Sigh
-symCo    = string "^ghczmprim:GHCziPrim.sym"      >> return SymC
-transCo  = string "^ghczmprim:GHCziPrim.trans"    >> return TransC 
-unsafeCo = string "^ghczmprim:GHCziPrim.CoUnsafe" >> return UnsafeC
-leftCo   = string "^ghczmprim:GHCziPrim.left"     >> return LeftC
-rightCo  = string "^ghczmprim:GHCziPrim.right"    >> return RightC
-
-coreFunTy :: Parser Ty
-coreFunTy = do
-  argTy <- coreBty
-  whiteSpace
-  symbol "->"
-  whiteSpace
-  resTy <- coreType
-  return $ tArrow argTy resTy
+symCo    = string "ghczmprim:GHCziPrim.sym"      >> return SymC
+transCo  = string "ghczmprim:GHCziPrim.trans"    >> return TransC 
+unsafeCo = string "ghczmprim:GHCziPrim.CoUnsafe" >> return UnsafeC
+leftCo   = string "ghczmprim:GHCziPrim.left"     >> return LeftC
+rightCo  = string "ghczmprim:GHCziPrim.right"    >> return RightC
+instCo   = string "ghczmprim:GHCziPrim.inst"    >> return InstC
 
 coreForallTy :: Parser Ty
 coreForallTy = do
@@ -267,7 +258,9 @@ coreKind = do
   return $ foldl Karrow hd maybeRest
 
 coreAtomicKind = try liftedKind <|> try unliftedKind 
-       <|> try openKind {- <|> try (parens equalityKind) -}
+       <|> try openKind <|> try (do
+                    (from,to) <- parens equalityKind
+                    return $ Keq from to)
        <|> try (parens coreKind)
 
 liftedKind = do
@@ -298,6 +291,7 @@ data ATyOp =
  | Unsafe ([Ty] -> Ty)
  | LeftCo ([Ty] -> Ty)
  | RightCo ([Ty] -> Ty)
+ | InstCo ([Ty] -> Ty)
 
 coreVdefGroups :: Parser [Vdefg]
 coreVdefGroups = option [] (do
@@ -316,7 +310,9 @@ coreRecVdef = do
 coreNonrecVdef = coreVdef >>= (return . Nonrec)
 
 coreVdef = do
-  (vdefLhs, vdefTy) <- topVbind
+  (vdefLhs, vdefTy) <- try topVbind <|> (do
+                        (v, ty) <- lambdaBind
+                        return (unqual v, ty))
   whiteSpace
   symbol "="
   whiteSpace
@@ -328,8 +324,7 @@ coreAtomicExp = do
 -- For stupid reasons, the whiteSpace is necessary.
 -- Without it, (pt coreAppExp "w ^a:B.C ") doesn't work.
   whiteSpace
-  res <- choice [ try coreVar,
-                    coreDcon,
+  res <- choice [try coreDconOrVar,
                     try coreLit,
                     parens coreFullExp ]
   whiteSpace
@@ -356,9 +351,13 @@ coreAppExp = do
     return $ foldl (\ op ->
                      either (App op) (Appt op)) oper args
 
-coreVar = ((try coreQualifiedName) <|> (identifier >>= (return . unqual)))
-             >>= (return . Var)
-coreDcon = coreQualifiedCon >>= (return . Dcon)
+coreDconOrVar = do
+  theThing <- coreQualifiedGen (try upperName <|> identifier)
+  return $ case theThing of
+    -- note that data constructors must be qualified
+    (Just _, idItself) | isUpper (head idItself)
+      -> Dcon theThing
+    _ -> Var theThing
 
 coreLit :: Parser Exp
 coreLit = parens (coreLiteral >>= (return . Lit))
@@ -434,7 +433,9 @@ coreVbind = parens (lambdaBind >>= (return . Vb))
 
 coreAtTbind = (symbol "@") >> coreTbind
 
+topVbind :: Parser (Qual Var, Ty)
 topVbind   = aCoreVbind coreQualifiedName
+lambdaBind :: Parser (Var, Ty)
 lambdaBind = aCoreVbind identifier
 
 aCoreVbind idP =  do
@@ -451,12 +452,15 @@ intOrRatLit :: Parser CoreLit
 intOrRatLit = do
  -- Int and lit combined into one to avoid ambiguity.
  -- Argh....
-  lhs <- anIntLit
+  lhs <- intLit
   maybeRhs <- optionMaybe (symbol "%" >> anIntLit)
   case maybeRhs of
     Nothing  -> return $ Lint lhs
     Just rhs -> return $ Lrational (lhs % rhs)
 
+intLit :: Parser Integer
+intLit = anIntLit <|> parens anIntLit
+
 anIntLit :: Parser Integer
 anIntLit = do
   sign <- option 1 (symbol "-" >> return (-1)) 
@@ -506,7 +510,6 @@ extCore = P.makeTokenParser extCoreDef
 
 parens          = P.parens extCore    
 braces          = P.braces extCore    
-semiSep1        = P.semiSep1 extCore    
 -- newlines are allowed anywhere
 whiteSpace      = P.whiteSpace extCore <|> (newline >> return ())
 symbol          = P.symbol extCore    
@@ -537,6 +540,7 @@ extCoreDef = LanguageDef {
     , caseSensitive   = True
     }       
 
+{-
 -- Stuff to help with testing in ghci.
 pTest (Left a) = error (show a)
 pTest (Right t) = print t
@@ -561,3 +565,4 @@ andThenSym a b = do
   p <- a
   symbol b
   return p
+-}
\ No newline at end of file