Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Informatik 8
CoPaR
Commits
22fed3e6
Commit
22fed3e6
authored
Jun 26, 2018
by
Hans-Peter Deifel
Browse files
Implement new functor parsing
parent
635e0f13
Changes
7
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
ma.cabal
View file @
22fed3e6
...
...
@@ -22,6 +22,7 @@ library
, Data.Functors.FixedProduct
, Data.Functors.MonoidValued
, Data.Functors
, Data.FunctorsNew
, Data.Sort
, Data.RefinablePartition
, Data.Vector.Unboxed.Mutable.Utils
...
...
@@ -33,6 +34,7 @@ library
, Text.Parser.Lexer
, Text.Parser.Types
, Text.Parser.Functor
, Text.Parser.FunctorNew
, Parser
, Algorithm
default-language: Haskell2010
...
...
src/Data/Functors.hs
View file @
22fed3e6
...
...
@@ -22,8 +22,3 @@ registeredFunctors =
where
f
::
RefinementInterface
a
=>
FunctorParser
a
->
SomeFunctorParser
f
=
SomeFunctorParser
-- new interface
type
AllFunctors
=
Union
'
[
Powerset'
,
FixedProduct'
,
MonoidValued'
Int
,
MonoidValued'
Double
]
src/Data/Functors/Powerset.hs
View file @
22fed3e6
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
...
...
@@ -12,11 +13,17 @@ import qualified Data.Yaml as Yaml
import
Data.RefinementInterface
import
qualified
Data.MorphismEncoding
as
Encoding
import
Text.Parser.Functor
import
Text.Parser.FunctorNew
import
qualified
Text.Parser.Lexer
as
L
-- New interface
data
Powerset'
a
=
Powerset'
a
deriving
(
Functor
)
instance
ParseFunctor
Powerset'
where
precedence
=
5
parseFunctor
=
Prefix'
(
L
.
symbol
"P"
>>
pure
Powerset'
)
-- Old interface
...
...
src/Data/FunctorsNew.hs
0 → 100644
View file @
22fed3e6
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
module
Data.FunctorsNew
where
import
Data.RefinementInterface
import
Data.Functors.Powerset
(
powerset
,
Powerset
'
)
import
Data.Functors.FixedProduct
(
FixedProduct
'
,
fixedproduct
)
import
Data.Functors.MonoidValued
(
MonoidValued
'
,
intValued
,
realValued
)
import
Data.OpenUnion
type
AllFunctors
=
'
[
Powerset'
,
FixedProduct'
,
MonoidValued'
Int
,
MonoidValued'
Double
]
data
Fix
f
=
Fix
(
f
(
Fix
f
))
newtype
NestedFunctors
=
NestedFunctors
(
Fix
(
Union
AllFunctors
))
src/Data/OpenUnion.hs
View file @
22fed3e6
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleInstances #-}
...
...
@@ -41,9 +43,13 @@ module Data.OpenUnion
,
inj
,
prj
,
Member
-- * Helpers for working with type lists
,
All
,
Sublist
)
where
import
Unsafe.Coerce
import
Data.Kind
-- | An open sum type.
--
...
...
@@ -103,3 +109,13 @@ unsafePrj :: Word -> Union ls a -> Maybe (f a)
unsafePrj
i1
(
In
i2
x
)
|
i1
==
i2
=
Just
(
unsafeCoerce
x
)
|
otherwise
=
Nothing
type
family
All
(
c
::
k
->
Constraint
)
(
xs
::
[
k
])
::
Constraint
where
All
_
'
[]
=
()
All
c
(
x
:
xs
)
=
(
c
x
,
All
c
xs
)
type
family
Sublist
(
xs
::
[
k
])
(
ys
::
[
k
])
::
Constraint
where
Sublist
'
[]
_
=
()
Sublist
(
x
:
xs
)
ys
=
(
Member
x
ys
,
Sublist
xs
ys
)
src/Text/Parser/Functor.hs
View file @
22fed3e6
...
...
@@ -9,6 +9,9 @@ module Text.Parser.Functor
)
where
import
Data.List
import
Data.Function
(
on
)
import
Text.Megaparsec
import
qualified
Text.Megaparsec.Expr
as
Expr
...
...
src/Text/Parser/FunctorNew.hs
0 → 100644
View file @
22fed3e6
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
module
Text.Parser.FunctorNew
where
import
Data.List
import
Data.Function
(
on
)
import
Text.Megaparsec
import
qualified
Text.Megaparsec.Expr
as
Expr
import
Text.Parser.Types
import
Text.Parser.Lexer
import
Data.RefinementInterface
import
Data.OpenUnion
data
FunctorParser'
a
=
Prefix'
(
Parser
a
)
|
Postfix'
(
Parser
a
)
deriving
(
Functor
)
data
Fix
f
=
Fix
(
f
(
Fix
f
))
type
NestedFunctors
fs
=
(
Fix
(
Union
fs
))
class
Functor
f
=>
ParseFunctor
f
where
precedence
::
Int
parseFunctor
::
FunctorParser'
(
a
->
f
a
)
toOp
::
forall
f
fs
.
(
Member
f
fs
,
ParseFunctor
f
)
=>
(
Int
,
Expr
.
Operator
Parser
(
NestedFunctors
fs
))
toOp
=
case
parseFunctor
@
f
of
Prefix'
p
->
(
precedence
@
f
,
Expr
.
Prefix
(
fmap
((
Fix
.
inj
@
f
@
fs
)
.
)
p
))
Postfix'
p
->
(
precedence
@
f
,
Expr
.
Postfix
(
fmap
((
Fix
.
inj
@
f
@
fs
)
.
)
p
))
class
ToOpTable
fs
(
lst
::
[
*
->
*
])
where
toOpTable
::
[(
Int
,
Expr
.
Operator
Parser
(
NestedFunctors
fs
))]
instance
ToOpTable
fs
'
[]
where
toOpTable
=
[]
instance
(
ParseFunctor
x
,
Member
x
fs
,
ToOpTable
fs
xs
)
=>
ToOpTable
fs
(
x
'
:
xs
)
where
toOpTable
=
toOp
@
x
@
fs
:
toOpTable
@
fs
@
xs
data
Hole
a
=
Hole
deriving
(
Functor
)
parseHole
::
Member
Hole
fs
=>
Parser
(
NestedFunctors
fs
)
parseHole
=
symbol
"X"
>>
return
(
Fix
(
inj
Hole
))
functorsParser'
::
forall
(
fs
::
[
*
->
*
])
.
ToOpTable
(
Hole
'
:
fs
)
fs
=>
Parser
(
NestedFunctors
(
Hole
'
:
fs
))
functorsParser'
=
let
sortedOps
=
sortBy
(
compare
`
on
`
fst
)
(
toOpTable
@
(
Hole
'
:
fs
)
@
fs
)
opTable
=
map
(
map
snd
)
(
groupBy
((
==
)
`
on
`
fst
)
sortedOps
)
termParser
=
parseHole
<|>
parens
functorsParser'
in
try
spaceConsumer
*>
Expr
.
makeExprParser
termParser
opTable
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment