diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,5 @@ # dhall-lex This is a library containing a lexer for the -[Dhall](http://hackage.haskell.org/package/dhall) language. +[Dhall](http://hackage.haskell.org/package/dhall) language. It is minimalistic +and performant. diff --git a/bench/Bench.hs b/bench/Bench.hs --- a/bench/Bench.hs +++ b/bench/Bench.hs @@ -6,9 +6,12 @@ main :: IO () main = - defaultMain [ env l $ \file -> + defaultMain [ env allEnv $ \ ~(big, med) -> bgroup "lexDhall" - [ bench "lexer" $ nf lexDhall file + [ bench "lexer (large)" $ nf lexDhall big + , bench "lexer (medium)" $ nf lexDhall med ] ] - where l = BSL.readFile "test/data/sample.dhall" + where l = BSL.readFile "test/data/big.dhall" + m = BSL.readFile "test/data/sample.dhall" + allEnv = (,) <$> l <*> m diff --git a/cabal.project.local b/cabal.project.local deleted file mode 100644 --- a/cabal.project.local +++ /dev/null @@ -1,8 +0,0 @@ --- constraints: dhall-lex +development -documentation: True - -allow-newer: - Cabal - -program-options - alex-options: -g diff --git a/dhall-lex.cabal b/dhall-lex.cabal --- a/dhall-lex.cabal +++ b/dhall-lex.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: dhall-lex -version: 0.1.0.1 +version: 0.2.0.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018 Vanessa McHale @@ -13,9 +13,7 @@ category: Lexers, Language, Dhall build-type: Simple data-files: - test/data/sample.dhall -extra-source-files: - cabal.project.local + test/data/*.dhall extra-doc-files: README.md source-repository head @@ -31,18 +29,19 @@ library exposed-modules: Language.Dhall.Lexer + build-tools: alex -any hs-source-dirs: src other-modules: Language.Dhall.Lexer.Mod Language.Dhall.Lexer.Types default-language: Haskell2010 ghc-options: -Wall - build-tools: alex build-depends: - base >=4.8 && <5, + base >=4.9 && <5, array -any, bytestring -any, - deepseq -any + deepseq -any, + scientific -any if flag(development) ghc-options: -Werror diff --git a/src/Language/Dhall/Lexer.hs b/src/Language/Dhall/Lexer.hs --- a/src/Language/Dhall/Lexer.hs +++ b/src/Language/Dhall/Lexer.hs @@ -1,6 +1,7 @@ -- | This module contains a dhall lexer. module Language.Dhall.Lexer ( -- * User functions lexDhall + , getDependencies -- * Types , Token , AlexPosn (..) @@ -9,10 +10,18 @@ , Operator (..) , Ann (..) -- * Internal - , step + , alexMonadScan + , runAlex , Alex (..) , AlexState (..) ) where +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as ASCII import Language.Dhall.Lexer.Mod import Language.Dhall.Lexer.Types + +getDependencies :: BSL.ByteString -> Either String [FilePath] +getDependencies = fmap (g =<<) . lexDhall + where g (Ann _ (EmbedFile s)) | BSL.head s /= 104 = [ASCII.unpack s] + g _ = mempty diff --git a/src/Language/Dhall/Lexer/Mod.x b/src/Language/Dhall/Lexer/Mod.x --- a/src/Language/Dhall/Lexer/Mod.x +++ b/src/Language/Dhall/Lexer/Mod.x @@ -8,7 +8,8 @@ module Language.Dhall.Lexer.Mod ( lexDhall - , step + , alexMonadScan + , runAlex , Alex (..) , AlexPosn (..) , Ann (..) @@ -22,6 +23,7 @@ import Data.Bool (bool) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as ASCII +import Data.Scientific import GHC.Generics (Generic) import GHC.Natural (Natural) import Language.Dhall.Lexer.Types @@ -32,6 +34,7 @@ $digit = 0-9 +@index = $digit+ @natural = \+ $digit+ @integer = (\- | "") $digit+ @double = (\- | "") $digit+ \. $digit+ @@ -43,15 +46,19 @@ $uppercase = [A-Z] $letter = [$lowercase $uppercase] -@type = $uppercase $letter* +@identifier_body = $letter | $digit | _ + +@type = $uppercase @identifier_body* @quoted = \` @type \` -@identifier = ($lowercase | _ | @type \/) $letter* +@identifier = ($lowercase | _) @identifier_body* -@loc = "http://" | "https://" | "./" | "../" | "/" +@url_loc = "http://" | "https://" +@file_loc = "./" | "../" | "/" -$url_contents = [\:\/\-\.\_ $letter] +$url_contents = [\:\/\-\.\_ $letter $digit] -@url = @loc $url_contents+ +@url = @url_loc $url_contents+ +@file = @file_loc $url_contents+ $string_char = $printable # [\"\\\$] @@ -74,9 +81,20 @@ <0,splice> let { tok (\p _ -> alex p $ Keyword KwLet) } <0,splice> in { tok (\p _ -> alex p $ Keyword KwIn) } <0,splice> forall { tok (\p _ -> alex p $ Keyword KwForall) } - <0,splice> ∀ { tok (\p _ -> alex p $ Keyword KwForall) } + <0,splice> "∀" { tok (\p _ -> alex p $ Keyword KwForall) } <0,splice> constructors { tok (\p _ -> alex p $ Keyword KwConstructors) } <0,splice> merge { tok (\p _ -> alex p $ Keyword KwMerge) } + <0,splice> Text { tok (\p _ -> alex p $ Keyword KwText) } + <0,splice> Double { tok (\p _ -> alex p $ Keyword KwDouble) } + <0,splice> Integer { tok (\p _ -> alex p $ Keyword KwInteger) } + <0,splice> List { tok (\p _ -> alex p $ Keyword KwList) } + <0,splice> Natural { tok (\p _ -> alex p $ Keyword KwNatural) } + <0,splice> Bool { tok (\p _ -> alex p $ Keyword KwBool) } + <0,splice> Optional { tok (\p _ -> alex p $ Keyword KwOptional) } + <0,splice> "Nat/fold" { tok (\p _ -> alex p $ Keyword KwNatFold) } + <0,splice> "Integer/show" { tok (\p _ -> alex p $ Keyword KwIntegerShow) } + <0,splice> Kind { tok (\p _ -> alex p $ Keyword KwKind) } + <0,splice> Type { tok (\p _ -> alex p $ Keyword KwType) } -- builtin specials <0,splice> "//" { tok (\p _ -> alex p $ Operator CombineTok) } @@ -94,18 +112,21 @@ <0,splice> \+\+ { tok (\p _ -> alex p $ Operator AppendTok) } -- Path literals - <0,splice> @url { tok (\p s -> alex p $ Embedded s) } + <0,splice> @url { tok (\p s -> alex p $ EmbedURL s) } + <0,splice> @file { tok (\p s -> alex p $ EmbedFile s) } -- Various special characters <0> $special { tok (\p s -> alex p $ Special s) } -- Numeric literals + <0,splice> @double { tok (\p s -> Ann p <$> fmap DoubleTok (readDouble s)) } <0,splice> @natural { tok (\p s -> Ann p <$> fmap NatLit (readNatural s)) } + <0,splice> \@ @index { tok (\p s -> Ann p <$> fmap AtToken (readInteger (BSL.tail s))) } <0,splice> @integer { tok (\p s -> Ann p <$> fmap IntLit (readInteger s)) } -- Boolean literals - <0,splice> True { tok (\p _ -> alex p $ BoolLit True) } - <0,splice> False { tok (\p _ -> alex p $ BoolLit False) } + <0,splice> True { tok (\p _ -> alex p $ BoolTok True) } + <0,splice> False { tok (\p _ -> alex p $ BoolTok False) } -- Identifiers <0,splice> @quoted { tok (\p s -> alex p $ QuotedId s) } @@ -129,22 +150,24 @@ where go :: Int -> AlexInput -> Alex Token go 0 input = alexSetInput input >> alexMonadScan - go n input = do + go n input = case alexGetByte input of Nothing -> err input - Just (c, input') -> do + Just (c, input') -> case Data.Char.chr (fromIntegral c) of - '-' -> do + '-' -> case alexGetByte input' of Nothing -> err input' Just (125,input_) -> go (n-1) input_ Just (_,input_) -> go n input_ - '{' -> do + '{' -> case alexGetByte input' of Nothing -> err input' - Just (c',input_) -> go (bool id (+1) (c'==45) $ n) input_ + Just (c',input_) -> go (addLevel c' $ n) input_ _ -> go n input' + addLevel c' = bool id (+1) (c'==45) + err (pos,_,_,_) = let (AlexPn _ line col) = pos in alexError ("Error in nested comment at line " ++ show line ++ ", column " ++ show col) @@ -154,7 +177,7 @@ where go x | x < 0 = alexError "Internal lexer error" go x = pure (fromIntegral x) -readDouble :: BSL.ByteString -> Alex Double +readDouble :: BSL.ByteString -> Alex Scientific readDouble str = pure $ read (ASCII.unpack str) readInteger :: BSL.ByteString -> Alex Integer @@ -189,14 +212,9 @@ lexDhall :: BSL.ByteString -> Either String [Token] lexDhall str = runAlex str loop --- | Get the next token. This is provided in case you want to thread the lexer --- through the parser. Returns @End@ token when out of input. -step :: Alex Token -step = alexMonadScan - loop :: Alex [Token] loop = do - tok' <- step + tok' <- alexMonadScan if inner tok' == End then pure mempty else (tok' :) <$> loop diff --git a/src/Language/Dhall/Lexer/Types.hs b/src/Language/Dhall/Lexer/Types.hs --- a/src/Language/Dhall/Lexer/Types.hs +++ b/src/Language/Dhall/Lexer/Types.hs @@ -8,6 +8,7 @@ import Control.DeepSeq (NFData) import qualified Data.ByteString.Lazy as BSL +import Data.Scientific import GHC.Generics (Generic) import GHC.Natural (Natural) @@ -32,21 +33,49 @@ | KwIf | KwThen | KwElse + | KwText + | KwDouble + | KwInteger + | KwList + | KwNatural + | KwBool + | KwOptional + | KwNatFold + | KwNatBuild + | KwNatIsZero + | KwNatEven + | KwNatOdd + | KwNatToInteger + | KwNatShow + | KwIntegerShow + | KwDoubleShow + | KwListBuild + | KwListFold + | KwListLength + | KwListHead + | KwListLast + | KwListIndexed + | KwListReverse + | KwOptionalFold + | KwOptionalBuild + | KwType + | KwKind deriving (Eq, Show, Generic, NFData) -- | This is a data type for tokens, stripped of any annotation. data TokenType = IntLit !Integer - | DoubleLit !Double + | DoubleTok !Scientific | NatLit !Natural - | BoolLit !Bool - | Embedded !BSL.ByteString - | StringLit !BSL.ByteString + | BoolTok !Bool + | EmbedFile !BSL.ByteString + | EmbedURL !BSL.ByteString | TypeId !BSL.ByteString | QuotedId !BSL.ByteString | Identifier !BSL.ByteString | Keyword !Keyword | Special !BSL.ByteString | Operator !Operator + | AtToken !Integer -- for e.g. @x\@0@. | BeginSplice -- @${@, only occurs inside a string | EndSplice -- @}@ | StringChunk !BSL.ByteString diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,13 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} import qualified Data.ByteString.Lazy as BSL +import Data.Either (isRight) import Language.Dhall.Lexer import Test.Hspec import Test.Hspec.Dirstream - -isRight :: Either a b -> Bool -isRight Right{} = True -isRight _ = False main :: IO () main = hspec $ diff --git a/test/data/big.dhall b/test/data/big.dhall new file mode 100644 --- /dev/null +++ b/test/data/big.dhall @@ -0,0 +1,172 @@ +{- Dhall prelude imports -} +let concatMapSep = https://ipfs.io/ipfs/QmQ8w5PLcsNz56dMvRtq54vbuPe9cNnCCUXAQp6xLc6Ccx/Prelude/Text/concatMapSep +in +let map = https://ipfs.io/ipfs/QmQ8w5PLcsNz56dMvRtq54vbuPe9cNnCCUXAQp6xLc6Ccx/Prelude/List/map +in + +{- Types for export and supporting functions -} +let ATSConstraint = { lower : Optional (List Integer), upper : Optional (List Integer) } +in + +let LibDep = { _1 : Text, _2 : ATSConstraint } +in + +let LinkType = { _1 : Text, _2 : Text } +in + +let ForeignCabal = { projectFile : Optional Text, cabalFile : Text, objectFile : Text } +in + +let TargetPair = { hs : Text, ats : Text, cpphs : Bool } +in + +let Bin = { src : Text, target : Text, libs : List Text, hsDeps : List ForeignCabal , hs2ats : List TargetPair, gcBin : Bool, extras : List Text } +in + +let Lib = { name : Text, src : List Text, libTarget : Text, libs : List Text, includes : List Text, hsDeps : List ForeignCabal, links : List LinkType, hs2ats : List TargetPair, extras : List Text, static : Bool } +in + +let Src = { atsSrc : Text, cTarget : Text, atsGen : List TargetPair, extras : List Text } +in + +{- Helper functions -} +let patsHome = + ".atspkg/contrib" +in + +let showVersion = + λ(x : List Integer) → concatMapSep "." Integer Integer/show x +in + +let none = [] : Optional (List Integer) +in +let plainDeps = λ(x : Text) → { _1 = x, _2 = { lower = none, upper = none } } +in + +let mapPlainDeps = λ(x : List Text) → map Text LibDep plainDeps x +in + +{- Default configurations -} +let dep = + { dir = ".atspkg/contrib" + , libVersion = [0,1,0] + , libDeps = [] + : List LibDep + , libBldDeps = [] + : List LibDep + , libCDeps = [] + : List LibDep + , description = [] + : Optional Text + } +in + +let common = + { libs = ([] : List Text) + , hsDeps = ([] : List ForeignCabal) + , hs2ats = ([] : List TargetPair) + , extras = ([] : List Text) + } +in + +let bin = + common ⫽ { gcBin = False } +in + +let lib = + common ⫽ + { links = ([] : List { _1 : Text, _2 : Text }) + , includes = ([] : List Text) + , static = False + } +in + +let staticLib = + lib ⫽ { static = True } +in + +let default + = { bin = [] + : List Bin + , test = [] + : List Bin + , libraries = [] + : List Lib + , man = ([] : Optional Text) + , completions = ([] : Optional Text) + , version = [0,3,9] + , compiler = [0,3,9] + , dependencies = [] + : List LibDep + , clib = [] + : List LibDep + , buildDeps = [] + : List LibDep + , ccompiler = "gcc" + , cflags = [ "-O2" ] + , atsSource = [] + : List Src + , dynLink = True + } +in + +{- Package functions -} +let makePkg = + λ(rec : { x : List Integer, name : Text, githubUsername : Text}) → + dep ⫽ + { libName = rec.name + , dir = "${patsHome}" + , url = "https:⫽github.com/${rec.githubUsername}/${rec.name}/archive/${showVersion rec.x}.tar.gz" + , libVersion = rec.x + } +in + +let makeNpmPkg = + λ(rec : { x : List Integer, name : Text, unpackDir : Text }) → + dep ⫽ + { libName = rec.name + , dir = "${patsHome}/${rec.unpackDir}" + , url = "https:⫽registry.npmjs.org/${rec.unpackDir}/-/${rec.unpackDir}-${showVersion rec.x}.tgz" + , libVersion = rec.x + } +in + +let makeHsPkg = + λ(rec : { x : List Integer, name : Text }) → + dep ⫽ + { libName = rec.name + , dir = "${patsHome}" + , url = "https:⫽hackage.haskell.org/package/${rec.name}-${showVersion rec.x}/${rec.name}-${showVersion rec.x}.tar.gz" + , libVersion = rec.x + } +in + +let makePkgDescr = + λ(x : { x : List Integer, name : Text, githubUsername : Text, description : Text }) → + makePkg { x = x.x, name = x.name, githubUsername = x.githubUsername } + ⫽ { description = [ x.description ] : Optional Text } +in + +{- We collect everything in a single record for convenience -} +{ Bin = Bin +, Lib = Lib +, Src = Src +, LibDep = LibDep +, LinkType = LinkType +, ForeignCabal = ForeignCabal +, TargetPair = TargetPair +, ATSConstraint = ATSConstraint +, showVersion = showVersion +, makePkg = makePkg +, bin = bin +, lib = lib +, dep = dep +, staticLib = staticLib +, default = default +, plainDeps = plainDeps +, mapPlainDeps = mapPlainDeps +, makePkgDescr = makePkgDescr +, makeHsPkg = makeHsPkg +, makeNpmPkg = makeNpmPkg +, patsHome = patsHome +} diff --git a/test/data/local.dhall b/test/data/local.dhall new file mode 100644 --- /dev/null +++ b/test/data/local.dhall @@ -0,0 +1,22 @@ +-- line comment +{- block comment -} +{- {- nested comment -} -} + +let boolSwitch = + if True != False + then "good" + else "something is off" +in + +let boolExpr = + True || False +in + +let map = https://ipfs.io/ipfs/QmQ8w5PLcsNz56dMvRtq54vbuPe9cNnCCUXAQp6xLc6Ccx/Prelude/List/map +in + +let function = + λ(x : List Integer) → map Integer Text Integer/show x +in + +boolSwitch diff --git a/test/data/sample.dhall b/test/data/sample.dhall --- a/test/data/sample.dhall +++ b/test/data/sample.dhall @@ -4,6 +4,10 @@ let Product = { first : Text, second : Optional (List Integer) } in +let atVar = + λ(x : Type) → λ(x : Type) → x@0 +in + let Sum = < Tag : Text | IntTag : Integer > in