{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} {-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-} module Parse.Pattern ( term , expression ) where import qualified Data.List as List import qualified Data.Name as Name import qualified Data.Utf8 as Utf8 import Foreign.Ptr (plusPtr) import qualified AST.Source as Src import qualified Parse.Keyword as Keyword import qualified Parse.Number as Number import qualified Parse.Space as Space import qualified Parse.String as String import qualified Parse.Variable as Var import qualified Parse.Primitives as P import Parse.Primitives (Parser, addLocation, addEnd, getPosition, inContext, oneOf, oneOfWithFallback, word1, word2) import qualified Reporting.Annotation as A import qualified Reporting.Error.Syntax as E -- TERM term :: Parser E.Pattern Src.Pattern term = do start <- getPosition oneOf E.PStart [ record start , tuple start , list start , termHelp start ] termHelp :: A.Position -> Parser E.Pattern Src.Pattern termHelp start = oneOf E.PStart [ do wildcard addEnd start Src.PAnything , do name <- Var.lower E.PStart addEnd start (Src.PVar name) , do upper <- Var.foreignUpper E.PStart end <- getPosition let region = A.Region start end return $ A.at start end $ case upper of Var.Unqualified name -> Src.PCtor region name [] Var.Qualified home name -> Src.PCtorQual region home name [] , do number <- Number.number E.PStart E.PNumber end <- getPosition case number of Number.Int int -> return (A.at start end (Src.PInt int)) Number.Float float -> P.Parser $ \(P.State _ _ _ _ row col) _ _ cerr _ -> let width = fromIntegral (Utf8.size float) in cerr row (col - width) (E.PFloat width) , do str <- String.string E.PStart E.PString addEnd start (Src.PStr str) , do chr <- String.character E.PStart E.PChar addEnd start (Src.PChr chr) ] -- WILDCARD wildcard :: Parser E.Pattern () wildcard = P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr -> if pos == end || P.unsafeIndex pos /= 0x5F {- _ -} then eerr row col E.PStart else let !newPos = plusPtr pos 1 !newCol = col + 1 in if Var.getInnerWidth newPos end > 0 then let (# badPos, badCol #) = Var.chompInnerChars newPos end newCol in cerr row col (E.PWildcardNotVar (Name.fromPtr pos badPos) (fromIntegral (badCol - col))) else let !newState = P.State src newPos end indent row newCol in cok () newState -- RECORDS record :: A.Position -> Parser E.Pattern Src.Pattern record start = inContext E.PRecord (word1 0x7B {- { -} E.PStart) $ do Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentOpen oneOf E.PRecordOpen [ do var <- addLocation (Var.lower E.PRecordField) Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd recordHelp start [var] , do word1 0x7D {-}-} E.PRecordEnd addEnd start (Src.PRecord []) ] recordHelp :: A.Position -> [A.Located Name.Name] -> Parser E.PRecord Src.Pattern recordHelp start vars = oneOf E.PRecordEnd [ do word1 0x2C {-,-} E.PRecordEnd Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentField var <- addLocation (Var.lower E.PRecordField) Space.chompAndCheckIndent E.PRecordSpace E.PRecordIndentEnd recordHelp start (var:vars) , do word1 0x7D {-}-} E.PRecordEnd addEnd start (Src.PRecord vars) ] -- TUPLES tuple :: A.Position -> Parser E.Pattern Src.Pattern tuple start = inContext E.PTuple (word1 0x28 {-(-} E.PStart) $ do Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExpr1 oneOf E.PTupleOpen [ do (pattern, end) <- P.specialize E.PTupleExpr expression Space.checkIndent end E.PTupleIndentEnd tupleHelp start pattern [] , do word1 0x29 {-)-} E.PTupleEnd addEnd start Src.PUnit ] tupleHelp :: A.Position -> Src.Pattern -> [Src.Pattern] -> Parser E.PTuple Src.Pattern tupleHelp start firstPattern revPatterns = oneOf E.PTupleEnd [ do word1 0x2C {-,-} E.PTupleEnd Space.chompAndCheckIndent E.PTupleSpace E.PTupleIndentExprN (pattern, end) <- P.specialize E.PTupleExpr expression Space.checkIndent end E.PTupleIndentEnd tupleHelp start firstPattern (pattern : revPatterns) , do word1 0x29 {-)-} E.PTupleEnd case reverse revPatterns of [] -> return firstPattern secondPattern : otherPatterns -> addEnd start (Src.PTuple firstPattern secondPattern otherPatterns) ] -- LIST list :: A.Position -> Parser E.Pattern Src.Pattern list start = inContext E.PList (word1 0x5B {-[-} E.PStart) $ do Space.chompAndCheckIndent E.PListSpace E.PListIndentOpen oneOf E.PListOpen [ do (pattern, end) <- P.specialize E.PListExpr expression Space.checkIndent end E.PListIndentEnd listHelp start [pattern] , do word1 0x5D {-]-} E.PListEnd addEnd start (Src.PList []) ] listHelp :: A.Position -> [Src.Pattern] -> Parser E.PList Src.Pattern listHelp start patterns = oneOf E.PListEnd [ do word1 0x2C {-,-} E.PListEnd Space.chompAndCheckIndent E.PListSpace E.PListIndentExpr (pattern, end) <- P.specialize E.PListExpr expression Space.checkIndent end E.PListIndentEnd listHelp start (pattern:patterns) , do word1 0x5D {-]-} E.PListEnd addEnd start (Src.PList (reverse patterns)) ] -- EXPRESSION expression :: Space.Parser E.Pattern Src.Pattern expression = do start <- getPosition ePart <- exprPart exprHelp start [] ePart exprHelp :: A.Position -> [Src.Pattern] -> (Src.Pattern, A.Position) -> Space.Parser E.Pattern Src.Pattern exprHelp start revPatterns (pattern, end) = oneOfWithFallback [ do Space.checkIndent end E.PIndentStart word2 0x3A 0x3A {-::-} E.PStart Space.chompAndCheckIndent E.PSpace E.PIndentStart ePart <- exprPart exprHelp start (pattern:revPatterns) ePart , do Space.checkIndent end E.PIndentStart Keyword.as_ E.PStart Space.chompAndCheckIndent E.PSpace E.PIndentAlias nameStart <- getPosition name <- Var.lower E.PAlias newEnd <- getPosition Space.chomp E.PSpace let alias = A.at nameStart newEnd name return ( A.at start newEnd (Src.PAlias (List.foldl' cons pattern revPatterns) alias) , newEnd ) ] ( List.foldl' cons pattern revPatterns , end ) cons :: Src.Pattern -> Src.Pattern -> Src.Pattern cons tl hd = A.merge hd tl (Src.PCons hd tl) -- EXPRESSION PART exprPart :: Space.Parser E.Pattern Src.Pattern exprPart = oneOf E.PStart [ do start <- getPosition upper <- Var.foreignUpper E.PStart end <- getPosition exprTermHelp (A.Region start end) upper start [] , do eterm@(A.At (A.Region _ end) _) <- term Space.chomp E.PSpace return (eterm, end) ] exprTermHelp :: A.Region -> Var.Upper -> A.Position -> [Src.Pattern] -> Space.Parser E.Pattern Src.Pattern exprTermHelp region upper start revArgs = do end <- getPosition Space.chomp E.PSpace oneOfWithFallback [ do Space.checkIndent end E.PIndentStart arg <- term exprTermHelp region upper start (arg:revArgs) ] ( A.at start end $ case upper of Var.Unqualified name -> Src.PCtor region name (reverse revArgs) Var.Qualified home name -> Src.PCtorQual region home name (reverse revArgs) , end )