Parser hackery

Ignore-this: b54366f14e4c4d6818b65db0bd75c906 darcs-hash:20111019144932-e29d1-55a219e957f9626c60164b0d5bee9f764d212eaf.gz
adamgundry · Oct 19, 2011 · ea02b74 · ea02b74
1 parent 8e9a9bf
commit ea02b74
Show file tree

Hide file tree

Showing 2 changed files with 19 additions and 25 deletions.
diff --git a/Parser.lhs b/Parser.lhs
@@ -56,7 +56,6 @@
 > doubleColon = reservedOp "::"
 
 
-
 Kinds
 
 > kind       = kindBit `chainr1` kindArrow
@@ -72,49 +71,41 @@ Types
 
 > tyVarName  = identLike True "type variable"
 > tyConName  = identLike False "type constructor"
+> numVarName = identLike True "numeric type variable"
 > tyVar      = STyVar <$> tyVarName
+> numVar     = STyVar <$> numVarName
 > tyCon      = STyCon <$> tyConName
 > tyExp      = tyAll <|> tyPi <|> tyQual <|> tyExpArr
 > tyAll      = tyQuant "forall" (SBind All)
 > tyPi       = tyQuant "pi" (SBind Pi)
 > tyExpArr   = tyBit `chainr1` tyArrow
 > tyArrow    = reservedOp "->" >> return (--->)
 
-
-> tyBit      = tyBob `chainl1` pure STyApp
-
-> {-
-> tyBob      =    tyVar
->            <|>  tyCon
->            <|>  STyInt <$> try integer
->            <|>  parens ((reservedOp "->" *> pure SArr <|> tyExp) <|> tyExp)
-> -}
-
-> numVarName   = identLike True "numeric type variable"
-> numVar       = STyVar <$> numVarName
-
-> tyBob = buildExpressionParser
+> tyBit = buildExpressionParser
 >     [
 >         [prefix "-" negate],
 >         [binary "^" (sbinOp Pow) AssocLeft],
 >         [binary "*" (*) AssocLeft],    
 >         [binary "+" (+) AssocLeft, sbinary "-" (-) AssocLeft]
 >     ]
->     tyAtom
+>     (tyAtom `chainl1` pure STyApp)
 
-> tyAtom     =    prefixBinOp <*> tyAtom <*> tyAtom
->            <|>  prefixUnOp <*> tyAtom
+> tyAtom     =    STyInt <$> try natural
+>            <|>  SBinOp <$> prefixBinOp
+>            <|>  SUnOp <$> prefixUnOp
 >            <|>  tyVar
 >            <|>  tyCon
->            <|>  STyInt <$> try integer
->            <|>  parens ((reservedOp "->" *> pure SArr <|> tyExp)
->                        <|> tyExp)
+>            <|>  parens ((reservedOp "->" *> pure SArr) <|> tyExp)
 
-> prefixBinOp  =    reserved "min" *> pure (sbinOp Min)
->              <|>  reserved "max" *> pure (sbinOp Max)
+> prefixBinOp  =    reserved "min" *> pure Min
+>              <|>  reserved "max" *> pure Max
+>              <|>  try (parens ((specialOp "-" *> pure Minus)
+>                                <|> (reservedOp "*" *> pure Times)
+>                                <|> (reservedOp "+" *> pure Plus)
+>                                <|> (reservedOp "^" *> pure Pow)))
 
-> prefixUnOp   =    reserved "abs" *> pure (sunOp Abs)
->              <|>  reserved "signum" *> pure (sunOp Signum)
+> prefixUnOp   =    reserved "abs" *> pure Abs
+>              <|>  reserved "signum" *> pure Signum
 
 > binary   name fun assoc = Infix (do{ reservedOp name; return fun }) assoc
 > sbinary  name fun assoc = Infix (do{ specialOp name; return fun }) assoc

diff --git a/Test.lhs b/Test.lhs
@@ -122,6 +122,8 @@
 >   "x = 2 + 3" :
 >   "x = 2 - 3" :
 >   "x = - 3" :
+>   "f :: f ((*) 3 2) -> g (+)\nf = undefined" :
+>   "x :: f min\nx = x" :
 >   []
 
 
@@ -397,6 +399,7 @@
 >   ("x = - 3", True) :
 >   ("f :: forall (f :: Num -> *)(a b :: Num) . f (2 ^ (a + b)) -> f (2 ^ a * 2 ^ b)\nf x = x", True) :
 >   ("f :: forall (f :: Num -> *)(a b :: Num) . f (2 ^ (2 * a)) -> f ((2 ^ a) ^ 2)\nf x = x", True) :
+>   ("f :: forall (f :: (Num -> Num) -> *) . f (min 2) -> f (min 2)\nf x = x", True) :
 >   []