shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Temp

--- a/src/MicroHs/Expr.hs

+++ b/src/MicroHs/Expr.hs

@@ -638,6 +638,7 @@

     Instance ct bs -> ppWhere (text "instance" <+> ppEType ct) bs

     Default mc ts -> text "default" <+> (maybe empty ppIdent mc) <+> parens (hsep (punctuate (text ", ") (map ppEType ts)))

     Pattern lhs@(i,_) p meqns -> text "pattern" <+> ppLHS lhs <+> text "=" <+> ppExpr p <+> maybe empty (ppWhere (text ";") . (:[]) . BFcn i) meqns

+    PatternSign is t -> text "pattern" <+> ppEDef (Sign is t)

     Deriving ct -> text "deriving instance" <+> ppEType ct

 ppDeriving :: Deriving -> Doc

--- a/src/MicroHs/Parse.hs

+++ b/src/MicroHs/Parse.hs

@@ -98,7 +98,7 @@

 pUIdentSym :: P Ident

 pUIdentSym = pUIdent <|< pParens pUSymOper

--- Special "identifiers": () [] (,) ...

+-- Special "identifiers": [] (,) ...

 pUIdentSpecial :: P Ident

 pUIdentSpecial = do

   loc <- getSLoc

@@ -345,7 +345,7 @@

    ) <|> (

     do pSymbol "<-"

        p <- pPat

-       meqns <- optional (pKeyword "where" *> pBraces (pEqns' (\ n _ -> i == n)))

+       meqns <- optional (pKeyword "where" *> pBraces (pEqnsU i))

        pure (lhs, p, fmap snd meqns)

    )

@@ -564,37 +564,44 @@

 -------------

+-- Regular function definition

 pEqns :: P (Ident, [Eqn])

-pEqns = pEqns' (\ _ _ -> True)

+pEqns = pEqns' pLIdentSym pLOper (\ _ _ -> True)

+  where pLOper = guardM pOper (not . isConIdent)

-pEqns' :: (Ident -> Int -> Bool) -> P (Ident, [Eqn])

-pEqns' pfst = do

-  (name, eqn@(Eqn ps alts)) <- pEqn pfst

+-- Pattern synonym function; must have name i.

+pEqnsU :: Ident -> P (Ident, [Eqn])

+pEqnsU i = pEqns' pUIdentSym pUOper (\ n _ -> i == n)

+

+-- pEqns' is used to parse oridinary function definitions as well

+-- as the 'constructor' of pattern synonyms, which has an upper case identifier.

+pEqns' :: P Ident -> P Ident -> (Ident -> Int -> Bool) -> P (Ident, [Eqn])

+pEqns' ident oper test = do

+  (name, eqn@(Eqn ps alts)) <- pEqn ident oper test

   case (ps, alts) of

     ([], EAlts [_] []) ->

       -- don't collect equations when of the form 'i = e'

       pure (name, [eqn])

     _ -> do

-      neqns <- emany (pSpec ';' *> pEqn (\ n l -> n == name && l == length ps))

+      neqns <- emany (pSpec ';' *> pEqn ident oper (\ n l -> n == name && l == length ps))

       pure (name, eqn : map snd neqns)

-pEqn :: (Ident -> Int -> Bool) -> P (Ident, Eqn)

-pEqn test = do

-  (name, pats) <- pEqnLHS

+pEqn :: P Ident -> P Ident -> (Ident -> Int -> Bool) -> P (Ident, Eqn)

+pEqn ident oper test = do

+  (name, pats) <- pEqnLHS ident oper

   alts <- pAlts (pSpec '=')

   guard (test name (length pats))

   pure (name, Eqn pats alts)

-pEqnLHS :: P (Ident, [EPat])

-pEqnLHS =

-  ((,) <$> pLIdentSym <*> emany pAPat)

+pEqnLHS :: P Ident -> P Ident -> P (Ident, [EPat])

+pEqnLHS ident oper =

+  ((,) <$> ident <*> emany pAPat)

   <|>   -- XXX this <|> causes a slowdown, but is necessary

   pOpLHS

   <|<

   ((\ (i, ps1) ps2 -> (i, ps1 ++ ps2)) <$> pParens pOpLHS <*> emany pAPat)

   where

-    pOpLHS = (\ p1 i p2 -> (i, [p1,p2])) <$> pPatApp <*> pLOper <*> pPatApp

-    pLOper = guardM pOper (not . isConIdent)

+    pOpLHS = (\ p1 i p2 -> (i, [p1,p2])) <$> pPatApp <*> oper <*> pPatApp

 pAlts :: P () -> P EAlts

 pAlts sep = do

--- a/src/MicroHs/TCMonad.hs

+++ b/src/MicroHs/TCMonad.hs

@@ -97,6 +97,7 @@

   dataTable   :: DataTable,             -- data/newtype definitions

   valueTable  :: ValueTable,            -- value symbol table

   assocTable  :: AssocTable,            -- values associated with a type, indexed by QIdent

+  patSynTable :: M.Map ([Ident], EPat), -- pattern synonyms

   uvarSubst   :: (IM.IntMap EType),     -- mapping from unique id to type

   tcMode      :: TCMode,                -- pattern, value, or type

   classTable  :: ClassTable,            -- class info, indexed by QIdent

--- a/src/MicroHs/TypeCheck.hs

+++ b/src/MicroHs/TypeCheck.hs

@@ -389,7 +389,8 @@

           classTable = gClassTable globs,

           ctxTables = (gInstInfo globs, [], [], []),

           constraints = [],

-          defaults = dflts

+          defaults = dflts,

+          patSynTable = M.empty

         }

 mergeDefaults :: Defaults -> Defaults -> Defaults

@@ -945,14 +946,15 @@

   dst <- tcDefsType ds

 --  tcTrace ("tcDefs 2:\n" ++ showEDefs dst)

   mapM_ addTypeAndData dst

-  dst' <- tcExpand impt dst

---  tcTrace ("tcDefs 3:\n" ++ showEDefs dst')

+  dstp <- tcPatSyn dst

+  dste <- tcExpand impt dstp

+  tcTrace ("tcDefs 3:\n" ++ showEDefs dste)

   case impt of

     ImpNormal -> do

-      setDefault dst'

-      tcDefsValue dst'

+      setDefault dste

+      tcDefsValue dste

     ImpBoot ->

-      return dst'

+      return dste

 setDefault :: [EDef] -> T ()

 setDefault defs = do

@@ -2942,3 +2944,17 @@

       _ -> tcError (getSLoc act) ("not data/newtype " ++ showIdent tname)

   -- We want 'instance ctx => cls ty'

   deriveNoHdr act lhs cs cls

+

+tcPatSyn :: [EDef] -> T [EDef]

+tcPatSyn ds = do

+  let one d@(Pattern (i, iks) p me) = do

+        addPatSyn i (map idKindIdent iks, p)

+        case me of

+          Nothing -> return [d]

+          Just e  -> return [d, Fcn i e]

+      one d = return [d]

+  concat <$> mapM one ds

+

+addPatSyn :: Ident -> ([Ident], EPat) -> T ()

+addPatSyn i ps =

+  modify $ \ ts -> ts{ patSynTable = M.insert i ps (patSynTable ts) }