overloaded 0.1 → 0.1.1
raw patch · 12 files changed
+692/−53 lines, 12 filesdep +singleton-booldep +time
Dependencies added: singleton-bool, time
Files
- CHANGELOG.md +8/−0
- example/Example.hs +2/−2
- overloaded.cabal +23/−14
- src/Overloaded.hs +8/−2
- src/Overloaded/Plugin.hs +110/−27
- src/Overloaded/Symbols.hs +72/−4
- src/Overloaded/TypeNats.hs +32/−0
- src/Overloaded/TypeSymbols.hs +27/−0
- test/Overloaded/Test/Symbols.hs +7/−4
- test/Overloaded/Test/TypeSymbols.hs +9/−0
- test/Regexp/Term.hs +73/−0
- test/Regexp/Type.hs +321/−0
+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# 0.1.1++- Add `Overloaded.TypeNats` and `Overloaded.TypeSymbols`+- Add `FromSymbol s Day` instance validating `yyyy-mm-dd` format++# 0.1++- Initial release
example/Example.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedLabels #-} -- {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols:Numerals:Lists:If:Labels=Overloaded.Symbols.fromSymbol #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols:Numerals:Lists:If:Labels=Overloaded.Symbols.fromSymbol:TypeNats #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -78,7 +78,7 @@ 1 + n @?= (3 :: Natural) -- fin: Fin- let f :: Fin (N.FromGHC 5)+ let f :: Fin 5 f = 2 print f
overloaded.cabal view
@@ -1,7 +1,7 @@-cabal-version: 2.2-name: overloaded-version: 0.1-synopsis: Overloaded pragmas as a plugin+cabal-version: 2.2+name: overloaded+version: 0.1.1+synopsis: Overloaded pragmas as a plugin description: Implement @Overloaded@ pragmas as a source plugin .@@ -17,12 +17,13 @@ {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Strings #-} @ -license: BSD-3-Clause-license-file: LICENSE-author: Oleg Grenrus <oleg.grenrus@iki.fi>-maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>-category: Plugin-tested-with: GHC ==8.6.5 || ==8.8.1+license: BSD-3-Clause+license-file: LICENSE+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+category: Plugin+extra-source-files: CHANGELOG.md+tested-with: GHC ==8.6.5 || ==8.8.1 source-repository head type: git@@ -41,6 +42,8 @@ Overloaded.Numerals Overloaded.Plugin Overloaded.Symbols+ Overloaded.TypeNats+ Overloaded.TypeSymbols -- GHC boot dependencies build-depends:@@ -49,6 +52,7 @@ , containers ^>=0.6.0.1 , ghc ^>=8.6 || ^>=8.8 , text ^>=1.2.3.0+ , time ^>=1.8.0.2 || ^>=1.9.3 -- other dependencies build-depends:@@ -96,6 +100,9 @@ Overloaded.Test.Numerals Overloaded.Test.Strings Overloaded.Test.Symbols+ Overloaded.Test.TypeSymbols+ Regexp.Term+ Regexp.Type -- inherited dependencies build-depends:@@ -107,11 +114,13 @@ , sop-core , symbols , text+ , time , vec -- test dependencies build-depends:- , generic-lens ^>=1.2.0.0- , lens ^>=4.18- , tasty ^>=1.2.3- , tasty-hunit ^>=0.10.0.2+ , generic-lens ^>=1.2.0.0+ , lens ^>=4.18+ , singleton-bool ^>=0.1.5+ , tasty ^>=1.2.3+ , tasty-hunit ^>=0.10.0.2
src/Overloaded.hs view
@@ -28,8 +28,12 @@ -- * Overloaded:Labels -- | See "GHC.OverloadedLabels" for 'GHC.OverloadedLabels.fromLabel'.- --- -- generic-lens example!++ -- * Overloaded:TypeNats+ FromNatC (..),++ -- * Overloade:TypeSymbols+ FromTypeSymbolC (..), ) where import Overloaded.Chars@@ -39,3 +43,5 @@ import Overloaded.Numerals import Overloaded.Plugin import Overloaded.Symbols+import Overloaded.TypeNats+import Overloaded.TypeSymbols
src/Overloaded/Plugin.hs view
@@ -16,7 +16,7 @@ import qualified ErrUtils as Err import qualified Finder import qualified GhcPlugins as GHC-import HsSyn+import HsSyn as GHC import qualified IfaceEnv import SrcLoc import qualified TcRnMonad as TcM@@ -60,6 +60,7 @@ -- * @Lists@ __is not__ like built-in @OverloadedLists@, but desugars explicit lists to 'Overloaded.Lists.cons' and 'Overloaded.Lists.nil' -- * @If@ desugars @if@-expressions to @'Overloaded.If.ifte' b t e@ -- * @Labels@ works like built-in @OverloadedLabels@ (you should enable @OverloadedLabels@ so parser recognises the syntax)+-- * @TypeNats@ and @TypeSymbols@ desugar type-level literals into @'Overloaded.TypeNats.FromNat'@ and @'Overloaded.TypeSymbols.FromTypeSymbol'@ respectively. -- -- == Known limitations --@@ -88,7 +89,7 @@ when (opts == defaultOptions) $ warn dflags noSrcSpan $ GHC.text "No Overloaded features enabled" - let transformNoOp :: LHsExpr GhcRn -> Maybe (LHsExpr GhcRn)+ let transformNoOp :: a -> Maybe a transformNoOp _ = Nothing trStr <- case optStrings of@@ -142,11 +143,27 @@ n <- lookupVarName dflags topEnv vn return $ transformLabels $ names { fromLabelName = n } - let tr = trStr /\ trNum /\ trChr /\ trLists /\ trIf /\ trLabel+ trTypeNats <- case optTypeNats of+ Off -> return transformNoOp+ On Nothing -> return $ transformTypeNats names+ On (Just vn) -> do+ n <- lookupTypeName dflags topEnv vn+ return $ transformTypeNats $ names { fromTypeNatName = n } - gr' <- transform dflags tr gr+ trTypeSymbols <- case optTypeSymbols of+ Off -> return transformNoOp+ On Nothing -> return $ transformTypeSymbols names+ On (Just vn) -> do+ n <- lookupTypeName dflags topEnv vn+ return $ transformTypeSymbols $ names { fromTypeSymbolName = n } - return (env, gr')+ let tr = trStr /\ trNum /\ trChr /\ trLists /\ trIf /\ trLabel+ let trT = trTypeNats /\ trTypeSymbols++ gr' <- transformType dflags trT gr+ gr'' <- transform dflags tr gr'++ return (env, gr'') where args = concatMap (splitOn ":") args' @@ -156,7 +173,7 @@ infixr 9 /\ -- hello CPP ---------------------------------------------------------------------------------- Args parasing+-- Args parsing ------------------------------------------------------------------------------- parseArgs :: GHC.DynFlags -> [String] -> TcRnTypes.TcM Options@@ -213,6 +230,12 @@ go opts "Labels" vns = do mvn <- oneName "Symbols" vns return $ opts { optLabels = On mvn }+ go opts "TypeNats" vns = do+ mvn <- oneName "TypeNats" vns+ return $ opts { optTypeNats = On mvn }+ go opts "TypeSymbols" vns = do+ mvn <- oneName "TypeSymbols" vns+ return $ opts { optTypeSymbols = On mvn } go opts s _ = do warn dflags noSrcSpan $ GHC.text $ "Unknown Overloaded option " ++ show s@@ -249,23 +272,27 @@ return (Just (VN (intercalate "." $ init ps) (last ps))) data Options = Options- { optStrings :: StrSym- , optNumerals :: NumNat- , optChars :: OnOff VarName- , optLists :: OnOff (V2 VarName)- , optIf :: OnOff VarName- , optLabels :: OnOff VarName+ { optStrings :: StrSym+ , optNumerals :: NumNat+ , optChars :: OnOff VarName+ , optLists :: OnOff (V2 VarName)+ , optIf :: OnOff VarName+ , optLabels :: OnOff VarName+ , optTypeNats :: OnOff VarName+ , optTypeSymbols :: OnOff VarName } deriving (Eq, Show) defaultOptions :: Options defaultOptions = Options- { optStrings = NoStr- , optNumerals = NoNum- , optChars = Off- , optLists = Off- , optIf = Off- , optLabels = Off+ { optStrings = NoStr+ , optNumerals = NoNum+ , optChars = Off+ , optLists = Off+ , optIf = Off+ , optLabels = Off+ , optTypeNats = Off+ , optTypeSymbols = Off } data StrSym@@ -399,6 +426,26 @@ transformLabels _ _ = Nothing -------------------------------------------------------------------------------+-- OverloadedTypeNats+-------------------------------------------------------------------------------++transformTypeNats :: Names -> LHsType GhcRn -> Maybe (LHsType GhcRn)+transformTypeNats Names {..} e@(L l (HsTyLit _ (HsNumTy _ _))) = do+ let name' = L l $ HsTyVar noExt GHC.NotPromoted $ L l fromTypeNatName+ Just $ L l $ HsAppTy noExt name' e+transformTypeNats _ _ = Nothing++-------------------------------------------------------------------------------+-- OverloadedTypeSymbols+-------------------------------------------------------------------------------++transformTypeSymbols :: Names -> LHsType GhcRn -> Maybe (LHsType GhcRn)+transformTypeSymbols Names {..} e@(L l (HsTyLit _ (HsStrTy _ _))) = do+ let name' = L l $ HsTyVar noExt GHC.NotPromoted $ L l fromTypeSymbolName+ Just $ L l $ HsAppTy noExt name' e+transformTypeSymbols _ _ = Nothing++------------------------------------------------------------------------------- -- Transform ------------------------------------------------------------------------------- @@ -414,6 +461,18 @@ Just e' -> e' Nothing -> e +transformType+ :: GHC.DynFlags+ -> (LHsType GhcRn -> Maybe (LHsType GhcRn))+ -> HsGroup GhcRn+ -> TcRnTypes.TcM (HsGroup GhcRn)+transformType _dflags f = SYB.everywhereM (SYB.mkM transform') where+ transform' :: LHsType GhcRn -> TcRnTypes.TcM (LHsType GhcRn)+ transform' e = do+ return $ case f e of+ Just e' -> e'+ Nothing -> e+ ------------------------------------------------------------------------------- -- Constructors -------------------------------------------------------------------------------@@ -461,20 +520,28 @@ ghcOverloadedLabelsMN :: GHC.ModuleName ghcOverloadedLabelsMN = GHC.mkModuleName "GHC.OverloadedLabels" +overloadedTypeNatsMN :: GHC.ModuleName+overloadedTypeNatsMN = GHC.mkModuleName "Overloaded.TypeNats"++overloadedTypeSymbolsMN :: GHC.ModuleName+overloadedTypeSymbolsMN = GHC.mkModuleName "Overloaded.TypeSymbols"+ ------------------------------------------------------------------------------- -- Names ------------------------------------------------------------------------------- data Names = Names- { fromStringName :: GHC.Name- , fromSymbolName :: GHC.Name- , fromNumeralName :: GHC.Name- , fromNaturalName :: GHC.Name- , fromCharName :: GHC.Name- , nilName :: GHC.Name- , consName :: GHC.Name- , ifteName :: GHC.Name- , fromLabelName :: GHC.Name+ { fromStringName :: GHC.Name+ , fromSymbolName :: GHC.Name+ , fromNumeralName :: GHC.Name+ , fromNaturalName :: GHC.Name+ , fromCharName :: GHC.Name+ , nilName :: GHC.Name+ , consName :: GHC.Name+ , ifteName :: GHC.Name+ , fromLabelName :: GHC.Name+ , fromTypeNatName :: GHC.Name+ , fromTypeSymbolName :: GHC.Name } getNames :: GHC.DynFlags -> GHC.HscEnv -> TcRnTypes.TcM Names@@ -489,6 +556,9 @@ ifteName <- lookupName dflags env overloadedIfMN "ifte" fromLabelName <- lookupName dflags env ghcOverloadedLabelsMN "fromLabel" + fromTypeNatName <- lookupName' dflags env overloadedTypeNatsMN "FromNat"+ fromTypeSymbolName <- lookupName' dflags env overloadedTypeSymbolsMN "FromTypeSymbol"+ return Names {..} lookupName :: GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> String -> TcM.TcM GHC.Name@@ -501,12 +571,25 @@ GHC.text "Cannot find module" GHC.<+> GHC.ppr mn fail "panic!" +lookupName' :: GHC.DynFlags -> GHC.HscEnv -> GHC.ModuleName -> String -> TcM.TcM GHC.Name+lookupName' dflags env mn vn = do+ res <- liftIO $ Finder.findImportedModule env mn Nothing+ case res of+ GHC.Found _ md -> IfaceEnv.lookupOrig md (GHC.mkTcOcc vn)+ _ -> do+ liftIO $ GHC.putLogMsg dflags GHC.NoReason Err.SevError noSrcSpan (GHC.defaultErrStyle dflags) $+ GHC.text "Cannot find module" GHC.<+> GHC.ppr mn+ fail "panic!"+ -- | Module name and variable name data VarName = VN String String deriving (Eq, Show) lookupVarName :: GHC.DynFlags -> GHC.HscEnv -> VarName -> TcM.TcM GHC.Name lookupVarName dflags env (VN vn mn) = lookupName dflags env (GHC.mkModuleName vn) mn++lookupTypeName :: GHC.DynFlags -> GHC.HscEnv -> VarName -> TcM.TcM GHC.Name+lookupTypeName dflags env (VN vn mn) = lookupName' dflags env (GHC.mkModuleName vn) mn ------------------------------------------------------------------------------- -- diagnostics
src/Overloaded/Symbols.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -14,12 +15,14 @@ FromSymbol (..), ) where -import Data.Proxy (Proxy (..))-import Data.String (fromString)-import Data.Symbol.Ascii (ToList)-import GHC.Exts (Constraint)+import Data.Proxy (Proxy (..))+import Data.String (fromString)+import Data.Symbol.Ascii (ToList)+import Data.Time.Calendar (Day, fromGregorian)+import GHC.Exts (Constraint) import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal)+import GHC.TypeNats import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL@@ -74,3 +77,68 @@ instance (KnownSymbol s, SeqList (ToList s)) => FromSymbol s BSL.ByteString where fromSymbol = fromString (symbolVal (Proxy :: Proxy s))++-------------------------------------------------------------------------------+-- time+-------------------------------------------------------------------------------++instance (KnownNat y, KnownNat m, KnownNat d, ParseDay s ~ '(y, m, d)) => FromSymbol s Day where+ fromSymbol = fromGregorian (integralVal @y) (integralVal @m) (integralVal @d)++integralVal :: forall n m. (KnownNat n, Num m) => m+integralVal = fromIntegral (natVal (Proxy :: Proxy n))++type family ParseDay (sym :: Symbol) :: (Nat, Nat, Nat) where+ ParseDay sym = ParseDay1 sym (ToList sym)++type a ** b = a GHC.TypeNats.* b+infixl 7 **++type family ParseDay1 (sym :: Symbol) (cs :: [Symbol]) :: (Nat, Nat, Nat) where+ ParseDay1 sym (y1 ': y2 ': y3 ': y4 ': "-" ': m1 ': m2 ': "-" ': d1 ': d2 :' [])+ = ParseDay2 sym (1000 ** TD y1 + 100 ** TD y2 + 10 ** TD y3 + TD y4) (10 ** TD m1 + TD m2) (10 ** TD d1 + TD d2)+ ParseDay1 sym cs = TypeError ('ShowType sym ':<>: 'Text " doesn't look like a date (yyyy-mm-dd)")++-- To Digit+type family TD (c :: Symbol) :: Nat where+ TD "0" = 0+ TD "1" = 1+ TD "2" = 2+ TD "3" = 3+ TD "4" = 4+ TD "5" = 5+ TD "6" = 6+ TD "7" = 7+ TD "8" = 8+ TD "9" = 9+ TD c = TypeError ('ShowType c ':<>: 'Text " is not a digit")++type family ParseDay2 (sym :: Symbol) (y :: Nat) (m :: Nat) (d :: Nat) :: (Nat, Nat, Nat) where+ ParseDay2 sym y m 0 = TypeError ('Text "Zero-day in " ':<>: 'ShowType sym)+ ParseDay2 sym y 0 d = TypeError ('Text "Zero-month in " ':<>: 'ShowType sym)+ ParseDay2 sym y m d = ParseDay3 sym y m d (d <=? DaysIn y m)++type family ParseDay3 (sym :: Symbol) (y :: Nat) (m :: Nat) (d :: Nat) (check :: Bool) :: (Nat, Nat, Nat) where+ ParseDay3 sym y m d 'True = '(y, m , d)+ ParseDay3 sym y m d 'False = TypeError ('Text "There are only " ':<>: 'ShowType (DaysIn y m) ':<>: 'Text " days in year-of-month of " ':<>: 'ShowType sym)++type family DaysIn (y :: Nat) (m :: Nat) where+ DaysIn y 1 = 31+ DaysIn y 2 = Leap (Mod y 4) (Mod y 100) (Mod y 400)+ DaysIn y 3 = 31+ DaysIn y 4 = 30+ DaysIn y 5 = 31+ DaysIn y 6 = 30+ DaysIn y 7 = 31+ DaysIn y 8 = 31+ DaysIn y 9 = 30+ DaysIn y 10 = 31+ DaysIn y 11 = 30+ DaysIn y 12 = 31+ DaysIn y m = TypeError ('Text "Overflowed month " ':<>: 'ShowType m)++type family Leap (a :: Nat) (b :: Nat) (c :: Nat) :: Nat where+ Leap a b 0 = 29+ Leap a 0 c = 28+ Leap 0 b c = 29+ Leap a b c = 28
+ src/Overloaded/TypeNats.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+-- | Overloaded type-level natural numbers.+module Overloaded.TypeNats where++import GHC.TypeNats (Nat)++import qualified Data.Type.Nat as N++-- | A way to overload type level 'Nat's.+--+-- A number type-literal @42@ is desugared to+--+-- @+-- 'FromNat' 42+-- @+--+-- Enabled with:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:TypeNats #-}+-- @+--+class FromNatC a where+ type family FromNat (n :: Nat) :: a++instance FromNatC Nat where+ type FromNat n = n++instance FromNatC N.Nat where+ type FromNat n = N.FromGHC n
+ src/Overloaded/TypeSymbols.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+-- | Overloaded type-level symbols.+module Overloaded.TypeSymbols where++import GHC.TypeLits (Symbol)++-- | A way to overload type level 'Symbol's.+--+-- A symbol type-literal @"example"@ is desugared to+--+-- @+-- 'FromTypeSymbol' "example"+-- @+--+-- Enabled with:+--+-- @+-- {-\# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:TypeSymbols #-}+-- @+--+class FromTypeSymbolC a where+ type family FromTypeSymbol (s :: Symbol) :: a++instance FromTypeSymbolC Symbol where+ type FromTypeSymbol s = s
test/Overloaded/Test/Symbols.hs view
@@ -10,12 +10,13 @@ {-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:Symbols #-} module Overloaded.Test.Symbols where -import Data.Proxy (Proxy (..))-import GHC.Exts (Constraint)+import Data.Proxy (Proxy (..))+import Data.Time.Calendar (fromGregorian)+import GHC.Exts (Constraint) import GHC.TypeLits (ErrorMessage (..), KnownSymbol, Symbol, TypeError, symbolVal)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=)) import Overloaded @@ -32,4 +33,6 @@ tests = testGroup "Symbols" [ testCase "NES" $ "foo" @?= NES "foo"+ , testCase "Day" $+ "2020-02-29" @?= fromGregorian 2020 02 29 ]
+ test/Overloaded/Test/TypeSymbols.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE DataKinds #-}+{-# OPTIONS -fplugin=Overloaded -fplugin-opt=Overloaded:TypeSymbols #-}+module Overloaded.Test.TypeSymbols where++import Data.Singletons.Bool (SBool (..))+import Regexp.Type (Matches)++example :: SBool (Matches "(foo|bar*)*q[u-w]x" "fooqux")+example = STrue
+ test/Regexp/Term.hs view
@@ -0,0 +1,73 @@+module Regexp.Term where++-- | Simple regular expressions.+data RE a+ = Eps -- ^ empty string+ | Chr [a] -- ^ character "sets", empty list means Empty!+ | App [RE a] -- ^ append+ | Alt [RE a] -- ^ union+ | Str (RE a) -- ^ star+ deriving (Show)++mkApp :: [RE a] -> RE a+mkApp [] = Eps+mkApp [r] = r+mkApp rs = App rs++mkAlt :: [RE a] -> RE a+mkAlt [] = Chr []+mkAlt [r] = r+mkAlt rs = Alt rs++mkStr :: RE a -> RE a+mkStr Eps = Eps+mkStr (Chr []) = Eps+mkStr (Str a) = Str a+mkStr a = Str a++type M = Either String++data Stack a+ = ES -- empty stack+ | Push [RE a] [RE a] (Stack a)+ deriving (Show)++type Result = M (RE Char)++parse :: [Char] -> Result+parse = parseGo ES [] []++mkAlt', mkApp' :: [RE a] -> RE a+mkAlt' = mkAlt . reverse+mkApp' = mkApp . reverse++parseGo+ :: Stack Char -- ^ stack+ -> [RE Char] -- ^ previous alternatives+ -> [RE Char] -- ^ previous appendables+ -> [Char] -- ^ input+ -> Result+parseGo ES alt app [] = Right (mkAlt' (mkApp' app : alt))+parseGo s alt app [] = Left (show $ "Non-empty stack at end-of-input " ++ show s)+parseGo s alt [] ('*' : cs) = Left (show "Unattached star")+parseGo s alt (x:xs) ('*' : cs) = parseGo s alt (mkStr x : xs) cs+parseGo s alt app ('|' : cs) = parseGo s (mkApp' app : alt) [] cs+parseGo s alt app ('(' : cs) = parseGo (Push alt app s) [] [] cs+parseGo s alt app (')' : cs) = case s of+ ES -> Left (show $ "Unmatched ) before " ++ cs)+ Push altP appP sP -> parseGo sP altP (mkAlt' (mkApp' app : alt) : appP) cs+parseGo s alt app ('[' : cs) = parseChr s alt app [] cs+parseGo s alt app (']' : cs) = Left ("Unmatched ] before " ++ cs)+parseGo s alt app (c : cs) = parseGo s alt (Chr [c] : app) cs++parseChr+ :: Stack Char -- ^ stack+ -> [RE Char] -- ^ previous alternatives+ -> [RE Char] -- ^ previous appendables+ -> [Char] -- ^ characters accumulator+ -> [Char] -- ^ input+ -> Result+parseChr s alt app acc [] = Left "Non-terminated character set at end-of-input"+parseChr s alt app acc (']' : cs) = parseGo s alt (Chr acc : app) cs+parseChr s alt app acc (c : '-' : c' : cs) = parseChr s alt app ([c .. c'] ++ acc) cs+parseChr s alt app acc (c : cs) = parseChr s alt app (c : acc) cs
+ test/Regexp/Type.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Regexp.Type (+ Parse,+ Matches,+ ) where++import Data.Symbol.Ascii (ToList)+import Data.Type.Bool+import GHC.TypeLits++import Overloaded+import Regexp.Term (RE (..), Stack (..))++-- $setup+-- >>> :set -XDataKinds++instance FromTypeSymbolC (RE Symbol) where+ type FromTypeSymbol s = Parse s++-------------------------------------------------------------------------------+-- Public+-------------------------------------------------------------------------------++-- | Parse 'Symbol' into 'RE'gular expression.+--+-- >>> :kind! Parse ""+-- Parse "" :: RE Symbol+-- = 'Eps+--+-- >>> :kind! Parse "(foo|bar*)*q[u-w]x"+-- Parse "(foo|bar*)*q[u-w]x" :: RE Symbol+-- = 'App+-- '['Str+-- ('Alt+-- '['App '['Chr '["b"], 'Chr '["a"], 'Str ('Chr '["r"])],+-- 'App '['Chr '["f"], 'Chr '["o"], 'Chr '["o"]]]),+-- 'Chr '["q"], 'Chr '["u", "v", "w"], 'Chr '["x"]]+--+type family Parse (cs :: Symbol) :: RE Symbol where+ Parse "" = Eps+ Parse cs = ParseGo ES '[] '[] (ToList cs)++-- | Match the regular expression against the symbol.+--+-- >>> type Regex = Parse "(foo|bar*)*q[u-w]x"+-- >>> :kind! Matches Regex ""+-- Matches Regex "" :: Bool+-- = 'False+--+-- >>> :kind! Matches Regex "fooqux"+-- Matches Regex "fooqux" :: Bool+-- = 'True+--+-- >>> :kind! Matches Regex "barrrrrqwx"+-- Matches Regex "barrrrrqwx" :: Bool+-- = 'True+--+-- >>> :kind! Matches Regex "barrrrrqwx!"+-- Matches Regex "barrrrrqwx!" :: Bool+-- = 'False+--+type family Matches (re :: RE Symbol) (cs :: Symbol) :: Bool where+ Matches re cs = MatchesGo re (ToList cs)++-------------------------------------------------------------------------------+-- Constructors+-------------------------------------------------------------------------------++type Empty = Chr '[]++type family MkAlt (alts :: [RE Symbol]) :: RE Symbol where+ MkAlt '[] = Empty+ MkAlt '[r] = r+ MkAlt rs = Alt rs++type family MkApp (apps :: [RE Symbol]) :: RE Symbol where+ MkApp '[] = Eps+ MkApp '[r] = r+ MkApp rs = App (Reverse rs)++type family MkStr (r :: RE Symbol) :: RE Symbol where+ MkStr Eps = Eps+ MkStr (Chr '[]) = Eps+ MkStr (Str r) = Str r+ MkStr r = Str r++-------------------------------------------------------------------------------+-- Parsing+-------------------------------------------------------------------------------++type family ParseGo (s :: Stack Symbol) (alt :: [RE Symbol]) (app :: [RE Symbol]) (cs :: [Symbol]) :: RE Symbol where+ ParseGo ES alt app '[] = MkAlt (MkApp app ': alt)+ ParseGo s alt app '[] = TypeError ('Text "Unexpected end-of-input, there is unclosed (")+ ParseGo s alt '[] ("*" : cs) = TypeError ('Text "Unattached star")+ ParseGo s alt (x : xs) ("*" : cs) = ParseGo s alt (MkStr x : xs) cs+ ParseGo s alt app ("|" : cs) = ParseGo s (MkApp app : alt) '[] cs+ ParseGo s alt app ("(" : cs) = ParseGo (Push alt app s) '[] '[] cs+ ParseGo s alt app (")" : cs) = ParseGoPop s alt app cs+ ParseGo s alt app ("[" : cs) = ParseChr s alt app '[] cs+ ParseGo s alt app ("]" : cs) = TypeError ('Text "Unmatched ] before " :<>: ShowType cs)+ ParseGo s alt app (c : cs) = ParseGo s alt (Chr '[c] : app) cs++type family ParseGoPop (s :: Stack Symbol) (alt :: [RE Symbol]) (app :: [RE Symbol]) (cs :: [Symbol]) :: RE Symbol where+ ParseGoPop ES _ _ cs = TypeError ('Text "Unmatched ) before " :<>: ShowType cs)+ ParseGoPop (Push altP appP s) alt app cs =+ ParseGo s altP (MkAlt (MkApp app : alt) : appP) cs++type family ParseChr (s :: Stack Symbol) (alt :: [RE Symbol]) (app :: [RE Symbol]) (acc :: [Symbol]) (cs :: [Symbol]) :: RE Symbol where+ ParseChr s alt app acc '[] = TypeError ('Text "Non-terminated character set")+ ParseChr s alt app acc ("]" : cs) = ParseGo s alt (Chr acc : app) cs+ ParseChr s alt app acc (c : "-" : c' : cs) = ParseChr s alt app (Append (FromTo c c') acc) cs+ ParseChr s alt app acc (c : cs) = ParseChr s alt app (c : acc) cs++-------------------------------------------------------------------------------+-- Matching+-------------------------------------------------------------------------------++type family MatchesGo (re :: RE Symbol) (cs :: [Symbol]) :: Bool where+ MatchesGo re '[] = Nullable re+ MatchesGo re (c : cs) = MatchesGo (Derivate re c) cs++type family Nullable (re :: RE Symbol) :: Bool where+ Nullable Eps = True+ Nullable (Chr cs) = False+ Nullable (App '[]) = True+ Nullable (App (r : rs)) = Nullable r && Nullable (App rs)+ Nullable (Alt '[]) = False+ Nullable (Alt (r : rs)) = Nullable r || Nullable (Alt rs)+ Nullable (Str r) = True++type family Derivate (re :: RE Symbol) (c :: Symbol) :: RE Symbol where+ Derivate Eps c = Empty+ Derivate (Chr cs) c = DerivateChr cs c+ Derivate (App rs) c = DerivateApp rs c+ Derivate (Alt rs) c = DerivateAlt rs c+ Derivate (Str r) c = MkApp '[ Derivate r c , Str r]++type family DerivateChr (cs :: [Symbol]) (c :: Symbol) :: RE Symbol where+ DerivateChr '[] c = Empty+ DerivateChr (x ': xs) x = Eps -- non-linear match+ DerivateChr (x ': xs) c = DerivateChr xs c++type family DerivateApp (rs :: [RE Symbol]) (c :: Symbol) where+ DerivateApp '[] c = Empty+ DerivateApp '[r] c = Derivate r c+ DerivateApp (r : rs) c = DerivateApp1 (Nullable r) r rs c++type family DerivateApp1 (n :: Bool) (r :: RE Symbol) (rs :: [RE Symbol]) (c :: Symbol) where+ DerivateApp1 False r rs c = App (Derivate r c : rs)+ DerivateApp1 True r rs c = MkAlt '[ App (Derivate r c : rs), DerivateApp rs c ]++type family DerivateAlt (rs :: [RE Symbol]) (c :: Symbol) :: RE Symbol where+ DerivateAlt rs c = MkAlt (MapDerivate rs c)++type family MapDerivate (rs :: [RE Symbol]) (c :: Symbol) :: [RE Symbol] where+ MapDerivate '[] c = '[]+ MapDerivate (r : rs) c = Derivate r c : MapDerivate rs c++-------------------------------------------------------------------------------+-- List+-------------------------------------------------------------------------------++type family Append (xs :: [k]) (ys :: [k]) :: [k] where+ Append '[] ys = ys+ Append (x : xs) ys = x : Append xs ys++type family Reverse (xs :: [k]) :: [k] where+ Reverse '[] = '[]+ Reverse (x ': xs) = Snoc (Reverse xs) x++type family Snoc (xs :: [k]) (x :: k) :: [k] where+ Snoc '[] y = '[y]+ Snoc (x ': xs) y = x ': Snoc xs y++-------------------------------------------------------------------------------+-- FromTo+-------------------------------------------------------------------------------++type family FromTo (a :: Symbol) (b :: Symbol) :: [Symbol] where+ FromTo a b = FromTo1 a b (CmpSymbol a b)++type family FromTo1 (a :: Symbol) (b :: Symbol) (o :: Ordering) :: [Symbol] where+ FromTo1 a b EQ = '[a]+ FromTo1 a b GT = '[]+ FromTo1 a b LT = a ': FromTo (SuccChar a) b++type family SuccChar (c :: Symbol) :: Symbol where+ SuccChar "\NUL" = "\SOH"+ SuccChar "\SOH" = "\STX"+ SuccChar "\STX" = "\ETX"+ SuccChar "\ETX" = "\EOT"+ SuccChar "\EOT" = "\ENQ"+ SuccChar "\ENQ" = "\ACK"+ SuccChar "\ACK" = "\a"+ SuccChar "\a" = "\b"+ SuccChar "\b" = "\t"+ SuccChar "\t" = "\n"+ SuccChar "\n" = "\v"+ SuccChar "\v" = "\f"+ SuccChar "\f" = "\r"+ SuccChar "\r" = "\SO"+ SuccChar "\SO" = "\SI"+ SuccChar "\SI" = "\DLE"+ SuccChar "\DLE" = "\DC1"+ SuccChar "\DC1" = "\DC2"+ SuccChar "\DC2" = "\DC3"+ SuccChar "\DC3" = "\DC4"+ SuccChar "\DC4" = "\NAK"+ SuccChar "\NAK" = "\SYN"+ SuccChar "\SYN" = "\ETB"+ SuccChar "\ETB" = "\CAN"+ SuccChar "\CAN" = "\EM"+ SuccChar "\EM" = "\SUB"+ SuccChar "\SUB" = "\ESC"+ SuccChar "\ESC" = "\FS"+ SuccChar "\FS" = "\GS"+ SuccChar "\GS" = "\RS"+ SuccChar "\RS" = "\US"+ SuccChar "\US" = " "+ SuccChar " " = "!"+ SuccChar "!" = "\""+ SuccChar "\"" = "#"+ SuccChar "#" = "$"+ SuccChar "$" = "%"+ SuccChar "%" = "&"+ SuccChar "&" = "'"+ SuccChar "'" = "("+ SuccChar "(" = ")"+ SuccChar ")" = "*"+ SuccChar "*" = "+"+ SuccChar "+" = ","+ SuccChar "," = "-"+ SuccChar "-" = "."+ SuccChar "." = "/"+ SuccChar "/" = "0"+ SuccChar "0" = "1"+ SuccChar "1" = "2"+ SuccChar "2" = "3"+ SuccChar "3" = "4"+ SuccChar "4" = "5"+ SuccChar "5" = "6"+ SuccChar "6" = "7"+ SuccChar "7" = "8"+ SuccChar "8" = "9"+ SuccChar "9" = ":"+ SuccChar ":" = ";"+ SuccChar ";" = "<"+ SuccChar "<" = "="+ SuccChar "=" = ">"+ SuccChar ">" = "?"+ SuccChar "?" = "@"+ SuccChar "@" = "A"+ SuccChar "A" = "B"+ SuccChar "B" = "C"+ SuccChar "C" = "D"+ SuccChar "D" = "E"+ SuccChar "E" = "F"+ SuccChar "F" = "G"+ SuccChar "G" = "H"+ SuccChar "H" = "I"+ SuccChar "I" = "J"+ SuccChar "J" = "K"+ SuccChar "K" = "L"+ SuccChar "L" = "M"+ SuccChar "M" = "N"+ SuccChar "N" = "O"+ SuccChar "O" = "P"+ SuccChar "P" = "Q"+ SuccChar "Q" = "R"+ SuccChar "R" = "S"+ SuccChar "S" = "T"+ SuccChar "T" = "U"+ SuccChar "U" = "V"+ SuccChar "V" = "W"+ SuccChar "W" = "X"+ SuccChar "X" = "Y"+ SuccChar "Y" = "Z"+ SuccChar "Z" = "["+ SuccChar "[" = "\\"+ SuccChar "\\" = "]"+ SuccChar "]" = "^"+ SuccChar "^" = "_"+ SuccChar "_" = "`"+ SuccChar "`" = "a"+ SuccChar "a" = "b"+ SuccChar "b" = "c"+ SuccChar "c" = "d"+ SuccChar "d" = "e"+ SuccChar "e" = "f"+ SuccChar "f" = "g"+ SuccChar "g" = "h"+ SuccChar "h" = "i"+ SuccChar "i" = "j"+ SuccChar "j" = "k"+ SuccChar "k" = "l"+ SuccChar "l" = "m"+ SuccChar "m" = "n"+ SuccChar "n" = "o"+ SuccChar "o" = "p"+ SuccChar "p" = "q"+ SuccChar "q" = "r"+ SuccChar "r" = "s"+ SuccChar "s" = "t"+ SuccChar "t" = "u"+ SuccChar "u" = "v"+ SuccChar "v" = "w"+ SuccChar "w" = "x"+ SuccChar "x" = "y"+ SuccChar "y" = "z"+ SuccChar "z" = "{"+ SuccChar "{" = "|"+ SuccChar "|" = "}"+ SuccChar "}" = "~"+ SuccChar "~" = "\DEL"+ SuccChar c = TypeError ('Text "SuccChar: out of ASCII range" :<>: ShowType c)+