morte 1.3.1 → 1.4.0

raw patch · 6 files changed

+225/−171 lines, 6 filesdep +EarleyPVP ok

version bump matches the API change (PVP)

Dependencies added: Earley

API changes (from Hackage documentation)

Files

• exec/Main.hs +2/−2
• morte.cabal +4/−2
• src/Morte/Core.hs +5/−0
• src/Morte/Lexer.x +16/−6
• src/Morte/Parser.hs +198/−0
• src/Morte/Parser.y +0/−161

@@ -22,8 +22,8 @@         <>  header "morte - A bare-bones calculus of constructions"         <>  progDesc "Type-check and normalize a Morte program, reading the \                      \program from standard input, writing the program's type \-                     \to standard error, and writing the normalized program to\-                     \standard output"+                     \to standard error, and writing the normalized program to \+                     \standard output."         )     inText   <- Text.getContents     expr     <- throws (exprFromText inText)

@@ -1,7 +1,8 @@ Name: morte-Version: 1.3.1+Version: 1.4.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple+Tested-With: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2 License: BSD3 License-File: LICENSE Copyright: 2014 Gabriel Gonzalez@@ -39,6 +40,7 @@         binary             >= 0.7.0.0  && < 0.8  ,         containers         >= 0.5.0.0  && < 0.6  ,         deepseq            >= 1.3.0    && < 1.5  ,+        Earley             >= 0.10.1.0 && < 0.11 ,         http-client        >= 0.4.0    && < 0.5  ,         http-client-tls    >= 0.2.0    && < 0.3  ,         microlens          >= 0.2.0.0  && < 0.4  ,@@ -56,7 +58,7 @@         Morte.Lexer,         Morte.Parser,         Morte.Tutorial-    Build-Tools: alex, happy+    Build-Tools: alex     GHC-Options: -O2  Executable morte

@@ -71,6 +71,7 @@ import Control.Applicative (Applicative(pure, (<*>)), (<$>)) import Control.DeepSeq (NFData(..)) import Control.Exception (Exception)+import Control.Monad (mzero) import Control.Monad.Trans.State (evalState) import qualified Control.Monad.Trans.State as State import Data.Binary (Binary(..), Get, Put)@@ -224,6 +225,10 @@  instance Buildable X where     build = absurd++instance Binary X where+    get = mzero+    put = absurd  -- | Syntax tree for expressions data Expr a

@@ -8,10 +8,11 @@      -- * Types     Token(..),-    Position(..)+    Position(..),+    LocatedToken(..)     ) where -import Control.Monad.Trans.State.Strict (State)+import Control.Monad.Trans.State.Strict (State, get) import Data.Bits (shiftR, (.&.)) import Data.Char (digitToInt) import Data.Text.Lazy (Text)@@ -20,7 +21,7 @@ import Filesystem.Path.CurrentOS (FilePath) import qualified Filesystem.Path.CurrentOS as Filesystem import Lens.Micro.Mtl ((.=), (+=))-import Pipes (Producer, lift, yield)+import Pipes (Producer, for, lift, yield) import Prelude hiding (FilePath)  }@@ -133,9 +134,13 @@     `lexExpr` keeps track of position and returns the remainder of the input if     lexing fails. -}-lexExpr :: Text -> Producer Token (State Position) (Maybe Text)-lexExpr text = go (AlexInput '\n' [] text)+lexExpr :: Text -> Producer LocatedToken (State Position) (Maybe Text)+lexExpr text = for (go (AlexInput '\n' [] text)) tag   where+    tag token = do+        pos <- lift get+        yield (LocatedToken token pos)+     go input = case alexScan input 0 of         AlexEOF                        -> return Nothing         AlexError (AlexInput _ _ text) -> return (Just text)@@ -147,6 +152,11 @@             lift (column += len)             go input' +data LocatedToken = LocatedToken+    { token    ::                !Token+    , position :: {-# UNPACK #-} !Position+    } deriving (Show)+ -- | Token type, used to communicate between the lexer and parser data Token     = OpenParen@@ -163,5 +173,5 @@     | File FilePath     | URL String     | EOF-    deriving (Show)+    deriving (Eq, Show) }

@@ -0,0 +1,198 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo       #-}++module Morte.Parser (+    -- * Parser+    exprFromText,++    -- * Errors+    ParseError(..),+    ParseMessage(..)+    ) where++import Control.Applicative hiding (Const)+import Control.Exception (Exception)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Error (Error(..), throwError, runErrorT)+import Control.Monad.Trans.State.Strict (evalState, get)+import Data.Monoid+import Data.Text.Buildable (Buildable(..))+import Data.Text.Lazy (Text)+import Data.Text.Lazy.Builder (toLazyText)+import Data.Typeable (Typeable)+import Filesystem.Path.CurrentOS (FilePath)+import Morte.Core (Var(..), Const(..), Path(..), Expr(..))+import Morte.Lexer (LocatedToken(..), Position(..), Token)+import Prelude hiding (FilePath)+import Text.Earley++import qualified Morte.Lexer    as Lexer+import qualified Pipes.Prelude  as Pipes+import qualified Data.Text.Lazy as Text++match :: Token -> Prod r Token LocatedToken Token+match t = fmap Lexer.token (satisfy predicate) <?> t+  where+    predicate (LocatedToken t' _) = t == t'++label :: Prod r e LocatedToken Text+label = fmap unsafeFromLabel (satisfy isLabel)+  where+    isLabel (LocatedToken (Lexer.Label _) _) = True+    isLabel  _                               = False++    unsafeFromLabel (LocatedToken (Lexer.Label l) _) = l++number :: Prod r e LocatedToken Int+number = fmap unsafeFromNumber (satisfy isNumber)+  where+    isNumber (LocatedToken (Lexer.Number _) _) = True+    isNumber  _                                = False++    unsafeFromNumber (LocatedToken (Lexer.Number n) _) = n++file :: Prod r e LocatedToken FilePath+file = fmap unsafeFromFile (satisfy isFile)+  where+    isFile (LocatedToken (Lexer.File _) _) = True+    isFile  _                              = False++    unsafeFromFile (LocatedToken (Lexer.File n) _) = n++url :: Prod r e LocatedToken String+url = fmap unsafeFromURL (satisfy isURL)+  where+    isURL (LocatedToken (Lexer.URL _) _) = True+    isURL  _                             = False++    unsafeFromURL (LocatedToken (Lexer.URL n) _) = n++expr :: Grammar r (Prod r Token LocatedToken (Expr Path))+expr = mdo+    expr <- rule+        (   bexpr+        <|> (   Lam+            <$> (match Lexer.Lambda *> match Lexer.OpenParen *> label)+            <*> (match Lexer.Colon *> expr)+            <*> (match Lexer.CloseParen *> match Lexer.Arrow *> expr)+            )+        <|> (   Pi+            <$> (match Lexer.Pi *> match Lexer.OpenParen *> label)+            <*> (match Lexer.Colon *> expr)+            <*> (match Lexer.CloseParen *> match Lexer.Arrow *> expr)+            )+        <|> (   Pi "_"+            <$> bexpr+            <*> (match Lexer.Arrow *> expr)+            )+        )+    vexpr <- rule+        (   (   V+            <$> label+            <*> (match Lexer.At *> number)+            )+        <|> (   V+            <$> label+            <*> pure 0+            )+        )+    bexpr <- rule+        (   (   App+            <$> bexpr+            <*> aexpr+            )+        <|> aexpr+        )+    aexpr <- rule+        (   (   Var+            <$> vexpr+            )+        <|> (   match Lexer.Star *> pure (Const Star)+            )+        <|> (   match Lexer.Box  *> pure (Const Box)+            )+        <|> (   Embed+            <$> import_+            )+        <|> (   match Lexer.OpenParen *> expr <* match Lexer.CloseParen+            )+        )++    import_ <- rule+        (   (   File+            <$> file+            )+        <|> (   URL+            <$> url+            )+        )++    return expr++-- | The specific parsing error+data ParseMessage+    -- | Lexing failed, returning the remainder of the text+    = Lexing Text+    -- | Parsing failed, returning the invalid token and the expected tokens+    | Parsing Token [Token]+    deriving (Show)++-- | Structured type for parsing errors+data ParseError = ParseError+    { position     :: Position+    , parseMessage :: ParseMessage+    } deriving (Typeable)++instance Show ParseError where+    show = Text.unpack . toLazyText . build++instance Exception ParseError++instance Buildable ParseError where+    build (ParseError (Lexer.P l c) e) =+            "\n"+        <>  "Line:   " <> build l <> "\n"+        <>  "Column: " <> build c <> "\n"+        <>  "\n"+        <>  case e of+            Lexing r                                     ->+                    "Lexing: \"" <> build remainder <> dots <> "\"\n"+                <>  "\n"+                <>  "Error: Lexing failed\n"+              where+                remainder = Text.takeWhile (/= '\n') (Text.take 64 r)+                dots      = if Text.length r > 64 then "..." else mempty+            Parsing t ts ->+                    "Parsing : " <> build (show t ) <> "\n"+                <>  "Expected: " <> build (show ts) <> "\n"+                <>  "\n"+                <>  "Error: Parsing failed\n"++{- This is purely to satisfy the unnecessary `Error` constraint for `ErrorT`++    I will switch to `ExceptT` when the Haskell Platform incorporates+    `transformers-0.4.*`.+-}+instance Error ParseError where++-- | Parse an `Expr` from `Text` or return a `ParseError` if parsing fails+exprFromText :: Text -> Either ParseError (Expr Path)+exprFromText text = evalState (runErrorT m) (Lexer.P 1 0)+  where+    m = do+        (locatedTokens, mtxt) <- lift (Pipes.toListM' (Lexer.lexExpr text))+        case mtxt of+            Nothing  -> return ()+            Just txt -> do+                pos <- lift get+                throwError (ParseError pos (Lexing txt))+        let (parses, Report _ needed found) =+                fullParses (parser expr) locatedTokens+        case parses of+            parse:_ -> return parse+            []      -> do+                let LocatedToken t pos = case found of+                        lt:_ -> lt+                        _    -> LocatedToken Lexer.EOF (P 0 0)+                throwError (ParseError pos (Parsing t needed))

@@ -1,161 +0,0 @@-{-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | Parsing logic for the Morte language--module Morte.Parser (-    -- * Parser-    exprFromText,--    -- * Errors-    ParseError(..),-    ParseMessage(..)-    ) where--import Control.Exception (Exception)-import Control.Monad.Trans.Error (ErrorT, Error(..), throwError, runErrorT)-import Control.Monad.Trans.State.Strict (State, runState)-import Data.Functor.Identity (Identity, runIdentity)-import Data.Monoid (mempty, (<>))-import Data.Text.Buildable (Buildable(..))-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as Text-import Data.Text.Lazy.Builder (toLazyText)-import Data.Typeable (Typeable)-import Lens.Micro (_1, _2)-import Lens.Micro.Mtl ((.=), use, zoom)-import Morte.Core (Var(..), Const(..), Path(..), Expr(..))-import qualified Morte.Lexer as Lexer-import Morte.Lexer (Token, Position)-import Pipes (Producer, hoist, lift, next)--}--%name parseExpr-%tokentype { Token }-%monad { Lex }-%lexer { lexer } { Lexer.EOF }-%error { parseError }--%token-    '('    { Lexer.OpenParen  }-    ')'    { Lexer.CloseParen }-    ':'    { Lexer.Colon      }-    '*'    { Lexer.Star       }-    '@'    { Lexer.At         }-    'BOX'  { Lexer.Box        }-    '->'   { Lexer.Arrow      }-    '\\'   { Lexer.Lambda     }-    '|~|'  { Lexer.Pi         }-    label  { Lexer.Label $$   }-    number { Lexer.Number $$  }-    file   { Lexer.File $$    }-    url    { Lexer.URL $$     }--%%--Expr :: { Expr Path }-    : BExpr                                   { $1           }-    | '\\'  '(' label ':' Expr ')' '->' Expr  { Lam $3 $5 $8 }-    | '|~|' '(' label ':' Expr ')' '->' Expr  { Pi  $3 $5 $8 }-    | BExpr '->' Expr                         { Pi "_" $1 $3 }--VExpr :: { Var }-    : label '@' number                        { V $1 $3      }-    | label                                   { V $1 0       }--BExpr :: { Expr Path }-    : BExpr AExpr                             { App $1 $2    }-    | AExpr                                   { $1           }--AExpr :: { Expr Path }-    : VExpr                                   { Var $1       }-    | '*'                                     { Const Star   }-    | 'BOX'                                   { Const Box    }-    | Import                                  { Embed $1     }-    | '(' Expr ')'                            { $2           }--Import :: { Path }-    : file                                    { File $1      }-    | url                                     { URL  $1      }--{--- | The specific parsing error-data ParseMessage-    -- | Lexing failed, returning the remainder of the text-    = Lexing Text-    -- | Parsing failed, returning the invalid token-    | Parsing Token-    deriving (Show)--{- This is purely to satisfy the unnecessary `Error` constraint for `ErrorT`--    I will switch to `ExceptT` when the Haskell Platform incorporates-    `transformers-0.4.*`.--}-instance Error ParseMessage where--type Status = (Position, Producer Token (State Position) (Maybe Text))--type Lex = ErrorT ParseMessage (State Status)---- To avoid an explicit @mmorph@ dependency-generalize :: Monad m => Identity a -> m a-generalize = return . runIdentity--lexer :: (Token -> Lex a) -> Lex a-lexer k = do-    x <- lift (do-        p <- use _2-        hoist generalize (zoom _1 (next p)) )-    case x of-        Left ml           -> case ml of-            Nothing -> k Lexer.EOF-            Just le -> throwError (Lexing le)-        Right (token, p') -> do-            lift (_2 .= p')-            k token--parseError :: Token -> Lex a-parseError token = throwError (Parsing token)---- | Parse an `Expr` from `Text` or return a `ParseError` if parsing fails-exprFromText :: Text -> Either ParseError (Expr Path)-exprFromText text = case runState (runErrorT parseExpr) initialStatus of-    (x, (position, _)) -> case x of-        Left  e    -> Left (ParseError position e)-        Right expr -> Right expr-  where-    initialStatus = (Lexer.P 1 0, Lexer.lexExpr text)---- | Structured type for parsing errors-data ParseError = ParseError-    { position     :: Position-    , parseMessage :: ParseMessage-    } deriving (Typeable)--instance Show ParseError where-    show = Text.unpack . toLazyText . build--instance Exception ParseError--instance Buildable ParseError where-    build (ParseError (Lexer.P l c) e) =-            "\n"-        <>  "Line:   " <> build l <> "\n"-        <>  "Column: " <> build c <> "\n"-        <>  "\n"-        <>  case e of-            Lexing r  ->-                    "Lexing: \"" <> build remainder <> dots <> "\"\n"-                <>  "\n"-                <>  "Error: Lexing failed\n"-              where-                remainder = Text.takeWhile (/= '\n') (Text.take 64 r)-                dots      = if Text.length r > 64 then "..." else mempty-            Parsing t ->-                    "Parsing: " <> build (show t) <> "\n"-                <>  "\n"-                <>  "Error: Parsing failed\n"-}