Commit 8def1dc5 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Turn on warnings-as-errors in curly-core

parent bff1258c
......@@ -2,7 +2,7 @@
-- documentation, see http://haskell.org/cabal/users-guide/
name: curly-core
version: 0.6.1
version: 0.6.2
-- synopsis:
-- description:
license: MIT
......@@ -42,8 +42,10 @@ library
RankNTypes
DeriveGeneric
AllowAmbiguousTypes
LambdaCase
other-extensions: UndecidableInstances, ScopedTypeVariables, StandaloneDeriving, PatternSynonyms, ViewPatterns, TypeFamilies, CPP, RecursiveDo, GADTs, DeriveGeneric, OverloadedStrings, NoMonomorphismRestriction, DeriveDataTypeable, ExistentialQuantification, BangPatterns
build-depends: bytestring, AES >=0.2 && <0.3,base >=4.9 && <4.10,base64-bytestring >=1.0 && <1.1,containers >=0.5 && <0.6,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=2.5 && <2.6,directory >=1.3 && <1.4,entropy >=0.3 && <0.4,hinotify >=0.3 && <0.4,network >=2.6 && <2.7,process >=1.4 && <1.5,zlib >=0.6 && <0.7
ghc-options: -Wall -Werror
hs-source-dirs: src
c-sources: sha256.c
default-language: Haskell2010
......@@ -17,6 +17,7 @@ module Curly.Core(
Compressed(..),noCurlySuf,(</>),format
) where
import Definitive
import Language.Format
import Curly.Core.Documentation
......@@ -83,13 +84,25 @@ instance Semantic (Free (ExprNode s) a) s a where
sem :: Semantic e i o => e -> SemanticT e i o
sem = by semNode
mkSymbol :: Semantic e i o => o -> e
mkSymbol x = SemSymbol x^..semNode
mkAbstract :: Semantic e i o => i -> e -> e
mkAbstract s e = SemAbstract s e^..semNode
mkApply :: Semantic e i o => e -> e -> e
mkApply a b = SemApply a b^..semNode
pattern PatSymbol :: Semantic e i o => o -> e
pattern PatSymbol s <- (sem -> SemSymbol s)
pattern PatAbstract :: Semantic e i o => i -> e -> e
pattern PatAbstract s e <- (sem -> SemAbstract s e)
pattern PatApply :: Semantic e i o => e -> e -> e
pattern PatApply f x <- (sem -> SemApply f x)
pattern PatApply2 :: Semantic e i o => e -> e -> e -> e
pattern PatApply2 f x y <- PatApply (PatApply f x) y
-- | Transform a lambda-like expression into another
......@@ -102,10 +115,10 @@ semantic e = case sem e of
-- | Tranform an expression into another, annotating it with contextual information.
{-# INLINE syntax #-}
syntax :: (Semantic e i o,Semantic e' i o'',Ord i) => (o -> o' -> o'') -> (o -> o') -> (o -> i) -> (Int -> o') -> e -> e'
syntax cons val name loc = syn (zero :: Int,c'map zero)
where syn (n,m) = fix $ \syn' e -> case sem e of
SemSymbol o -> mkSymbol $ cons o $ maybe (val o) (loc . \m -> (n-m)-1) (m^.at (name o))
SemAbstract i e' -> mkAbstract i (syn (n+1,insert i n m) e')
syntax mergeSym val name loc = syn (zero :: Int,c'map zero)
where syn (depth,syms) = fix $ \syn' e -> case sem e of
SemSymbol o -> mkSymbol $ mergeSym o $ maybe (val o) (loc . \depth' -> (depth-depth')-1) (syms^.at (name o))
SemAbstract i e' -> mkAbstract i (syn (depth+1,insert i depth syms) e')
SemApply f x -> mkApply (syn' f) (syn' x)
-- | Maps a function over lambda parameters in an expression
......@@ -116,8 +129,6 @@ mapParams f = doMap
SemAbstract s e -> mkAbstract (f s) (doMap e)
SemApply a b -> mkApply (doMap a) (doMap b)
instance FormatArg PortNumber where argClass _ = 'p'
instance (Documented s,Documented a) => Documented (Expression s a) where
document expr = docTag' "expr" [Pure $ show' "" expr]
where
......@@ -140,11 +151,11 @@ instance Show B64Chunk where
to x = [x]
instance Read B64Chunk where
readsPrec _ = readsParser $ do
let from '-' = '/'
from '_' = '+'
from x = x
let tr '-' = '/'
tr '_' = '+'
tr x = x
pad c = c+take (negate (length c)`mod`4) "===="
c <- many' (from <$> satisfy p)
c <- many' (tr <$> satisfy p)
(const zero <|> return . B64Chunk) (Base64.decode (pad c^..i'elems))
where p x = inRange 'a' 'z' x || inRange 'A' 'Z' x || inRange '0' '9' x || x=='_' || x=='-'
......@@ -178,6 +189,7 @@ curlyCommitDir = curlyDirPath (curlyUserDir + "/commits")
data LogLevel = Quiet | Verbose | Debug
deriving (Eq,Ord)
-- The global log level, as set by the environment variable CURLY_LOGLEVEL
envLogLevel :: LogLevel
envLogLevel = envVar "quiet" "CURLY_LOGLEVEL"
& fromMaybe Quiet . matches Just (foldl1' (<+?) [x<$several s | (x,s) <- levels])
where levels = [(Quiet,"quiet"),(Verbose,"verbose"),(Debug,"debug")]
......@@ -209,8 +221,10 @@ liftIOLog = liftIO . trylogLevel Quiet unit
-- | A global INotify instance
inotify :: INotify
inotify = initINotify^.thunk
-- | Sets a watch on the given file, on the usual signals
watchFile :: FilePath -> IO () -> IO WatchDescriptor
watchFile s f = addWatch inotify [Modify,Create,Delete,Move,MoveIn,MoveOut,MoveSelf] s (\_ -> f)
-- | A utility function that opens a client socket to the given server and port
......@@ -248,7 +262,7 @@ instance (Traversable f,HasIdents s s' (f (Free f' a)) (f' (Free f' a))) => HasI
where f (Pure a) = pure (Pure a)
f (Join ffa) = map Join (traverse f ffa >>= traversel ff'idents k)
instance forall s s' g g' f f' a. (Traversable f,HasIdents s s' (g a) (g' a), HasIdents s s' (f (g' a)) (f' (g' a))) => HasIdents s s' ((f:.:g) a) ((f':.:g') a) where
ff'idents k (Compose x) = Compose<$>(traversel (traverse.ff'idents) k x >>= \x -> traversel ff'idents k (x :: f (g' a)))
ff'idents k (Compose x) = Compose<$>(traversel (traverse.ff'idents) k x >>= \y -> traversel ff'idents k (y :: f (g' a)))
instance HasIdents s s' (ExprNode s a) (ExprNode s' a) where
ff'idents k (Lambda s a) = k s <&> \s' -> Lambda s' a
ff'idents _ (Apply x y) = pure (Apply x y)
......@@ -291,7 +305,7 @@ data Builtin = B_Undefined
| B_Open | B_Read | B_Write | B_Close
deriving (Eq,Ord,Show,Generic)
instance Documented Builtin where
document b = Pure (show' b)
document = Pure . show'
where show' (B_Number n) = show n
show' (B_String s) = show s
show' b = show b
......@@ -306,12 +320,14 @@ instance Serializable a => Serializable (Compressed a) where
instance Format a => Format (Compressed a) where
datum = (datum <&> decompress) >*> (Compressed <$> datum)
noCurlySuf :: FilePath -> Maybe FilePath
noCurlySuf f = nosuffix ".cy" f + nosuffix ".curly" f + nosuffix ".cyl" f
where nosuffix s s' = if t==s then Just h else Nothing
where (h,t) = splitAt (length s'-length s) s'
newtype LibraryID = LibraryID Chunk
deriving (Eq,Ord,Generic)
idSize :: Int
idSize = 32
instance Serializable LibraryID where
encode (LibraryID x) = x^.chunkBuilder
......
This diff is collapsed.
......@@ -19,7 +19,8 @@ module Curly.Core.Documentation(
) where
import Definitive
import Language.Format
import Language.Format hiding (letter)
import IO.Network.Socket (PortNumber)
-- | A documentation node (similar to a HTML node, but simpler)
data DocNode a = DocTag String [(String,String)] [a]
......@@ -56,7 +57,7 @@ instance Format Metadata where datum = coerceDatum Metadata
instance DataMap Metadata String (Free (Map String) String) where
at i = from i'Metadata.at i
instance Show Metadata where
show (Metadata m) = showM m
show = \(Metadata m) -> showM m
where showM m = format "{%s}" (intercalate " " [format "%s:%s" (show a) (showV v)
| (a,v) <- m^.ascList])
showV (Pure s) = show s
......@@ -64,15 +65,15 @@ instance Show Metadata where
instance Read Metadata where
readsPrec _ = readsParser (map Metadata brack)
where val = map Pure readable <+? map Join brack
brack = fromAList <$> between (single '{') (single '}') (sepBy' assoc (single ' '))
where assoc = liftA2 (,) readable (single ':' >> val)
brack = fromAList <$> between (single '{') (single '}') (sepBy' field (single ' '))
where field = liftA2 (,) readable (single ':' >> val)
instance Documented Metadata where
document m = Pure (show m)
type DocParams = Forest (Map String) Documentation
type DocPatterns = Map String ([String],Documentation)
evalDocWithPatterns :: DocPatterns -> DocParams -> Documentation -> Maybe Documentation
evalDocWithPatterns pats vars = eval vars
evalDocWithPatterns pats = eval
where eval vars = eval'
where
eval' (Pure x) = return (Pure x)
......@@ -102,6 +103,7 @@ evalDocWithPatterns pats vars = eval vars
guard (a==b)
sequence_ (zipWith (liftOp cmp) xs ys)
liftOp _ _ _ = Nothing
toCmp :: String -> [Integer :+: String] -> [Integer :+: String] -> Bool
toCmp "<" = (<)
toCmp ">" = (>)
toCmp "<=" = (<=)
......@@ -116,10 +118,10 @@ evalDocWithPatterns pats vars = eval vars
return (Join $ DocTag a [] zs)
cmp _ _ = Nothing
join $ liftA2 cmp (eval' ea) (eval' eb)
eval' x@(Join (DocTag "call" _ xs@(_:_))) = do
eval' (Join (DocTag "call" _ xs@(_:_))) = do
p:args <- traverse eval' xs
p <- p^?t'Pure
(pargs,pat) <- pats^.at p
pname <- p^?t'Pure
(pargs,pat) <- pats^.at pname
callTag args pargs pat
eval' (Join (DocTag t as xs)) = do
xs' <- traverse eval' xs
......@@ -133,7 +135,7 @@ evalDocWithPatterns pats vars = eval vars
wildcards "*" = unit
wildcards ('*':'*':t) = wildcards ('*':t)
wildcards ('*':t@(c:_)) = do
skipMany1' (satisfy (/=c))`sepBy`many1' (single c)
_ <- skipMany1' (satisfy (/=c))`sepBy`many1' (single c)
wildcards t
wildcards (c:t) = single c >> wildcards t
wildcards [] = eoi
......@@ -141,15 +143,19 @@ evalDocWithPatterns pats vars = eval vars
evalDoc :: DocParams -> Documentation -> Maybe Documentation
evalDoc = evalDocWithPatterns zero
nodoc :: String -> Documentation
nodoc msg = Join (DocTag "nodoc" [] [Pure msg])
mkDoc :: String -- ^ The root tag name
-> String -- ^ Documentation in textual format
-> Documentation
mkDoc t d = Join . DocTag t [] $ fromMaybe [] $ matches Just (between spc spc (sepBy' docAtom spc)) d
spc :: (ParseStream c s, ParseToken c, TokenPayload c ~ Char,Monad m) => ParserT s m ()
spc = skipMany' (oneOf " \t\n")
docAtom :: (ParseStream c s, ParseToken c, TokenPayload c ~ Char,Monad m) => ParserT s m Documentation
docAtom = tag <+? txt
where letter p = token >>= \c -> case c of
where letter p = token >>= \case
'\\' -> token
_ | (c`isKeyIn`reserved) || not (p c) -> zero
c | (c`isKeyIn`reserved) || not (p c) -> zero
| otherwise -> return c
reserved = c'set (fromKList " \t\n{}\\")
nameTo cs = many1' (letter (\c -> not (c`isKeyIn`res)))
......@@ -176,7 +182,7 @@ docLine :: (ParseToken c, ParseStream c s, TokenPayload c ~ Char, Monad m)
=> String -> [(String,String)] -> ParserT s m Documentation
docLine n as = Join . DocTag n as <$> many1' (skipMany' (oneOf " \t") >> docAtom)
showRawDoc :: Documentation -> String
showRawDoc x = case x of
showRawDoc = \case
Join (DocTag t as xs) -> "{" + foldMap quoteChar t + foldMap showAttr as + foldMap showSub xs + "}"
Pure s -> foldMap quoteChar s
where quoteChar ' ' = "\\ "
......@@ -378,6 +384,7 @@ instance FormatArg Int where argClass _ = 'd'
instance FormatArg Float where argClass _ = 'f'
instance FormatArg Double where argClass _ = 'f'
instance FormatArg String where argClass _ = 's'; showFormat = id
instance FormatArg PortNumber where argClass _ = 'p'
-- | A function that mimics sprintf-style formatting for Haskell
format :: FormatType r => String -> r
......
This diff is collapsed.
......@@ -25,9 +25,6 @@ import Language.Format hiding (space,hspace)
import Control.Exception
import Data.Typeable (Typeable)
instance IsString (Set Char) where
fromString = fromKList
newtype ParseExpr s a = ParseExpr (((,) SourceRange :.: Free (ExprNode s:.:(,) SourceRange)) a)
deriving (Functor,Foldable,Unit,SemiApplicative,Applicative)
instance Monad (ParseExpr s) where join = coerceJoin ParseExpr
......@@ -37,24 +34,35 @@ instance Traversable (ParseExpr s) where sequence = coerceSequence ParseExpr
type SourceExpr = ParseExpr String (String,Maybe (NameExpr GlobalID))
pattern PE :: (SourceRange, Free (ExprNode s :.: (,) SourceRange) a) -> ParseExpr s a
pattern PE e = ParseExpr (Compose e)
pattern PESym :: SourceRange -> a -> ParseExpr s a
pattern PESym r s = ParseExpr (Compose (r,Pure s))
pattern PEApp :: SourceRange
-> (SourceRange, Free (ExprNode s :.: (,) SourceRange) a)
-> (SourceRange, Free (ExprNode s :.: (,) SourceRange) a)
-> ParseExpr s a
pattern PEApp r f x = ParseExpr (Compose (r,Join (Compose (Apply f x))))
pattern PELam :: SourceRange
-> s
-> (SourceRange, Free (ExprNode s :.: (,) SourceRange) a)
-> ParseExpr s a
pattern PELam r s e = ParseExpr (Compose (r,Join (Compose (Lambda s e))))
impossible :: a
impossible = error "The impossible has happened"
instance Semantic (ParseExpr s a) s a where
semNode = iso f g
where f (PESym _ a) = SemSymbol a
f (PELam _ s e) = SemAbstract s (PE e)
f (PEApp _ f x) = SemApply (PE f) (PE x)
f _ = impossible
g (SemSymbol a) = PESym zero a
g (SemApply (PE f@(r,_)) (PE x@(r',_))) = PEApp (r+r') f x
g (SemApply _ _) = impossible
g (SemAbstract s (PE e@(r,_))) = PELam r s e
g (SemAbstract _ _) = impossible
semNode = iso go back
where go (PESym _ a) = SemSymbol a
go (PELam _ s e) = SemAbstract s (PE e)
go (PEApp _ f x) = SemApply (PE f) (PE x)
go _ = impossible
back (SemSymbol a) = PESym zero a
back (SemApply (PE f@(r,_)) (PE x@(r',_))) = PEApp (r+r') f x
back (SemApply _ _) = impossible
back (SemAbstract s (PE e@(r,_))) = PELam r s e
back (SemAbstract _ _) = impossible
data OpChar = OC_Char Char
| OC_CompleteChar Char
......@@ -65,7 +73,7 @@ instance Monoid OpStream where
zero = OpStream zero zero
instance Stream OpChar OpStream where
cons c (OpStream h l) = OpStream h ((c,('\0',0,0,0)):(l & set (t'head.l'2.l'1)
(case c of OC_Char c -> c ; _ -> '\0')))
(case c of OC_Char cc -> cc ; _ -> '\0')))
uncons (OpStream _ []) = Nothing
uncons (OpStream h ((c,_):l)) = Just (c,OpStream (case c of OC_Char c' -> c':h ; _ -> h) l)
instance ParseToken OpChar where
......@@ -86,14 +94,20 @@ mkStream = OpStream "" . mk ('\0',0,0,0)
nextChar c s' = (OC_Char c,(p,n,ln,cl)):mk (c,n+1,ln,cl+1) s'
type OpMap_Val = ((Int,Bool),String)
type OpMap = Cofree (Map Char) (Maybe OpMap_Val)
newtype OpMap = OpMap { getOpMap :: Cofree (Map Char) (Maybe OpMap_Val) }
i'OpMap :: Iso' (Cofree (Map Char) (Maybe OpMap_Val)) OpMap
i'OpMap = iso OpMap getOpMap
type OpParser m = ParserT OpStream (RWST Void [Warning] (Int,OpMap,(Map String (NameExpr GlobalID),Library)) m)
data Spaces = HorizSpaces | AnySpaces
parseSpaces :: (Monad m,ParseStream c s, TokenPayload c ~ Char) => Spaces -> ParserT s m ()
class (MonadParser s m p, ParseStream c s, TokenPayload c ~ Char) => MonadCharParser c s m p
instance (Monad m, ParseStream c s, TokenPayload c ~ Char) => MonadCharParser c s (StateT s m) (ParserT s m)
parseSpaces :: MonadCharParser c s m p => Spaces -> p ()
parseSpaces HorizSpaces = hspc
parseSpaces AnySpaces = spc
parseNBSpaces :: (Monad m,ParseStream c s, TokenPayload c ~ Char) => Spaces -> ParserT s m ()
parseNBSpaces :: MonadCharParser c s m p => Spaces -> p ()
parseNBSpaces HorizSpaces = nbhsp
parseNBSpaces AnySpaces = nbsp
......@@ -104,18 +118,13 @@ withParsedString ma = do
h' <- runStreamState (id <~ \(OpStream h' l) -> (OpStream (h'+h) l,reverse h'))
return (h',a)
instance Lens1 a a (Cofree f a) (Cofree f a) where
l'1 k (Step x f) = k x <&> \x' -> Step x' f
instance Lens2 (f (Cofree f a)) (f (Cofree f a)) (Cofree f a) (Cofree f a) where
l'2 k (Step x f) = k f <&> Step x
instance Semigroup OpMap where
Step x y + Step x' y' = Step (x+x') (y*+y')
OpMap (Step x y) + OpMap (Step x' y') = OpMap (Step (x+x') (map getOpMap (map OpMap y*+map OpMap y')))
instance Monoid OpMap where
zero = Step zero zero
zero = OpMap (Step zero zero)
instance DataMap OpMap String OpMap_Val where
at [] = l'1
at (c:cs) = l'2.mat c.at cs
at [] = from i'OpMap.l'1
at (c:cs) = from i'OpMap.l'2.at c.mapping i'OpMap.l'Just zero.at cs
data Severity = Sev_Info | Sev_Error
instance Show Severity where
......@@ -147,7 +156,9 @@ opKeyword s = expected (format "opKeyword '%s'" s) (several s)
guardWarn :: Monad m => Severity -> String -> Bool -> OpParser m ()
guardWarn sev msg p = if p then unit else (warn sev msg >> zero)
l'library :: Lens a b (x,y,(z,a)) (x,y,(z,b))
l'library = l'3.l'2
l'typeMap :: Lens a b (x,y,(a,z)) (x,y,(b,z))
l'typeMap = l'3.l'1
parseCurly :: (ParseStream c s, TokenPayload c ~ Char,Monad m) => s -> OpParser m a -> m ([Warning]:+:a)
......@@ -158,46 +169,56 @@ parseCurly s p = (deduce p^..mapping i'RWST.stateT) (mkStream s) zero <&> \((_,m
mkRange :: SourcePos -> SourcePos -> SourceRange
mkRange p p' = SourceRange Nothing p p'
mkLet :: Semantic e i o => Either (i, Maybe e) [e] -> e -> e
mkLet (Left (s,v)) = maybe id (flip mkApply) v . mkAbstract s
mkLet (Right t) = \e -> foldl1' mkApply (t+[e])
space, spc, hspc, nbsp, nbhsp, hspace
:: (Monad m,ParseStream c s, TokenPayload c ~ Char) => ParserT s m ()
space = hspace + (eol >> skipMany' ("#" >> skipMany' (satisfy (/='\n')) >> eol))
:: MonadCharParser c s m p => p ()
space = hspace + (eol >> skipMany' (single '#' >> skipMany' (satisfy (/='\n')) >> eol))
hspace = void $ oneOf [' ', '\t']
spc = skipMany' space
hspc = skipMany' hspace
nbsp = skipMany1' space
nbhsp = skipMany1' hspace
floating, swaying, wrapRound, wrapCurly :: Monad m => OpParser m a -> OpParser m a
floating = between spc spc
swaying = between hspc hspc
wrapRound = between "(" (expected ")" ")") . floating
wrapCurly = between "{" (expected "}" "}") . floating
previousChar :: Monad m => OpParser m Char
previousChar = remaining <&> \(OpStream _ s) -> case s of
[] -> '\0'
((_,(p,_,_,_)):_) -> p
currentPos :: Monad m => OpParser m (Int,Int,Int)
currentPos = remaining <&> \(OpStream _ s) -> case s of
[] -> (0,0,0)
((_,(_,n,l,c)):_) -> (n,l,c)
name :: Monad m => OpParser m String
name = do
pr <- previousChar
guard (not (isLetter pr)) >> many1' (satisfy isLetter <+? qChar)
<+? guard (not (isOperator pr)) >> many1' (satisfy isOperator <+? qChar)
where qChar = single '\\' >> token
isOperator c = not (elem c (c'set "{(_\"')} \t\n\\") || isLetter c)
isOperator, isLetter :: Char -> Bool
isOperator c = not (elem c (c'set $ fromKList "{(_\"')} \t\n\\") || isLetter c)
isLetter c = isAlpha c || inRange '0' '9' c || c=='\''
edgeName :: Bool -> String
edgeName t = if t then "_" else ""
mkSymName :: Bool -> [String] -> Bool -> Bool -> String
mkSymName l s r isR = edgeName l + intercalate "_" s + edgeName r + edgeName isR
symEdge :: Monad m => OpParser m Bool
symEdge = option' False (True<$"_")
varName :: Monad m => OpParser m String
varName = liftA4 mkSymName symEdge (name`sepBy1'`"_") symEdge symEdge >>= \n ->
if isKeyIn (last n) (c'set ":=")
if isKeyIn (last n) (c'set $ fromKList ":=")
then init n <$ runStreamState (modify (cons (OC_Char (last n)))) <*= guard . nonempty
else return n
......@@ -208,15 +229,15 @@ tom, expr, accessorExpr :: Monad m => Spaces -> OpParser m SourceExpr
expr sp = foldl1' mkApply<$>sepBy1' (tom sp) (parseNBSpaces sp)
accessorExpr sp = expr sp <*= \e -> defAccessors (map fst (toList e))
completing :: Monad m => OpParser Id a -> OpParser m [(String,a)]
completing p = do
OpStream _ t <- runStreamState get
st <- lift get
let Id (ret,_,_) = (p^..mapping i'RWST.parserT) (OpStream "" t) (undefined,st)
return [(reverse h,x) | (OpStream h _,x) <- ret]
-- completing :: Monad m => OpParser Id a -> OpParser m [(String,a)]
-- completing p = do
-- OpStream _ t <- runStreamState get
-- st <- lift get
-- let Id (ret,_,_) = (p^..mapping i'RWST.parserT) (OpStream "" t) (undefined,st)
-- return [(reverse h,x) | (OpStream h _,x) <- ret]
tom sp = do
Step _ opmap <- lift (getl l'2)
OpMap (Step _ opmap) <- lift (getl l'2)
typeMap <- lift (getl l'typeMap)
let param m c = case m^.at c of Just tl -> return tl ; _ -> zero
tokParam m = multi <+? (param m =<< (oneOfSet (delete '_' $ keysSet m) <*= guard . (/='_')))
......@@ -236,7 +257,7 @@ tom sp = do
<+? (maxBound,mkSymbol Nothing)<$"_"
mkOp n = foldl' mkApply (mkSymbol (Just (mkSymIn typeMap n)))
suffix p mod = suff
suffix p argPrefix = suff
where
filterM cmp = snd . go
where go (Step x xs) = let x' = x <*= guard . cmp . fst . fst
......@@ -250,19 +271,19 @@ tom sp = do
<+? suff (filterM (< d) (Step Nothing m))
suff (Step Nothing m) = suffM m
suffM m = (tokParam m >>= suff) <+? do
tl <- param m '_'
guard (any (maybe False (p . fst . fst)) tl)
let exprSuf tl@(Step _ tlm) | empty tlm = zero
| otherwise = between spc spc (operation AnySpaces (>=0))
>>= \(_,e) -> suffix p (mod . (e:)) tl
case tl :: OpMap of
Step (Just ((d,isR),n)) m' | p d -> do
>>= \(_,e) -> suffix p (argPrefix . (e:)) tl
tl <- param m '_'
guard (any (maybe False (p . fst . fst)) tl)
case tl of
Step (Just ((d,isR),n)) _ | p d -> do
foldr1 (<+?) [ exprSuf (filterM (> d) tl)
, spc >> operation sp (if isR then (>=d) else (>d))
<&> \(d',e) -> (min d d',mkOp n (mod [e]))
<&> \(d',e) -> (min d d',mkOp n (argPrefix [e]))
, exprSuf (filterM (> d) tl)]
_ -> exprSuf tl
suffO ((d,_),n) | p d = return (d,mkOp n (mod []))
suffO ((d,_),n) | p d = return (d,mkOp n (argPrefix []))
suffO _ = zero
trim x = case sem x of
......@@ -288,9 +309,9 @@ atom = withPostfix
sepBy1' (tom AnySpaces) nbsp <&> \args e -> foldl' mkApply e args
withPostfix s = foldl' (\e n -> mkApply (mkSymbol ('.':n,Nothing)) e) s
<$> many' (single '.' >> many1' letter)
string c = between (single c) (single c) $ mkConcat . g . foldr f ("",[]) <$> many' stringExpr
string delim = between (single delim) (single delim) $ mkConcat . g . foldr f ("",[]) <$> many' stringExpr
where stringExpr = map Left (single '$' >> wrapCurly (expr AnySpaces))
<+? map Right (single '\\' >> unquote<$>token <+? satisfy (/=c))
<+? map Right (single '\\' >> unquote<$>token <+? satisfy (/=delim))
unquote 'n' = '\n'
unquote 't' = '\t'
unquote '0' = '\0'
......@@ -301,7 +322,7 @@ atom = withPostfix
f (Left e) x = ("",e:g x)
f (Right c) ~(s,es) = (c:s,es)
g ("",es) = es
g (s,es) = mkSymbol (c:(s+[c]),Nothing):es
g (s,es) = mkSymbol (delim:(s+[delim]),Nothing):es
lambda = do
old <- lift get
......@@ -342,7 +363,7 @@ curlyFile = do
when (envLogLevel >= Debug) (mtrace "Finished parsing")
lift (getl l'library)
where modFile = do
"#!/lib/module!#" <+? "module"
_ <- "#!/lib/module!#" <+? "module"
syn <- hspc *> synopsis <* (eol+eoi)
lift (l'library.metadata =~ syn)
skipMany' (muteOnSuccess (curlyLine <+> (hspc >> eol)))
......@@ -376,7 +397,7 @@ curlyLine = expected "Curly source definition ('define', 'type', 'family', 'impo
mods <- sepBy1' modTree nbhsp
resolved <- fold<$>traverse resolve mods
guardWarn Sev_Info (format "Nothing to import for '%s' in the current context" (show mods)) (nonempty resolved)
let newinsts = c'set $ fromKList $ fold [toList (zipWith const ?mountain mod) | mod <- mods]
let newinsts = c'set $ fromKList $ fold [toList (zipWith const ?mountain m) | m <- mods]
addID fl (GlobalID n Nothing) = GlobalID n (Just (n,fl^.flID))
addID _ i = i
c x = x :: InstanceMap GlobalID (Maybe LibraryID,LeafExpr GlobalID)
......@@ -442,6 +463,9 @@ curlyLine = expected "Curly source definition ('define', 'type', 'family', 'impo
defClass cl args indices (mkRange pre post) tp
comment = id <$ raw "#" <* skipMany' (satisfy (/='\n'))
defClass :: Monad m => String -> [String] -> [[String]] -> SourceRange
-> (Library -> Type GlobalID)
-> OpParser m (Library -> Library)
defClass cl args indices range tp = do
l <- lift (getl l'library)
let l' = defRigidSymbols args l
......@@ -452,6 +476,8 @@ defClass cl args indices range tp = do
t = abstractImplicitType (pureIdent cl,map (fromKList . (>>= index)) fullIndices) args (tp l')
register cl
return (defTypeSym cl True range t expr_identity)
defAccessors :: Monad m => [String] -> OpParser m ()
defAccessors syms = do
l <- lift (getl l'library)
for_ [a | a@('.':_) <- syms] $ \ac ->
......@@ -462,14 +488,17 @@ defAccessors syms = do
e = "x" /> (("y" /> sym "b" ! sym "...")
! (sym "a"!sym "x"))
in do
mod <- defClass ac ["a","b"] [["a"]] NoRange $ \l ->
exprType $ exprIn l (e :: SourceExpr)
lift (l'library =~ mod)
patch <- defClass ac ["a","b"] [["a"]] NoRange $ \l' ->
exprType $ exprIn l' (e :: SourceExpr)
lift (l'library =~ patch)
defTypeSym :: String -> Bool -> SourceRange -> Type GlobalID -> RawNameExpr GlobalID -> Library -> Library
defTypeSym n isM rng tp e = symbols.at n.l'Just (undefSymLeaf n Nothing) %~
set leafVal (set t'exprType tp (_rawNameExpr e))
. set leafPos rng
. set leafType tp . set leafIsMethod isM
defRigidSymbols :: [String] -> Library -> Library
defRigidSymbols args = compose [defTypeSym a False NoRange (rigidTypeFun a) expr_identity
| a <- args]
......@@ -481,6 +510,10 @@ typeSum = do
exprs <- sepBy1' (foldl1' mkApply <$> sepBy1' typeNode nbhsp) delim
post <- currentPos